CODEWITHSUNDEEP
excelvbacsv
DigitalSea
DigitalSea

Reputation: 191

Open CSV, Copy Paste Range to Workbook

I am having trouble getting the copied range to paste in the destination workbook. I have a .csv file that will have one worksheet, but the worksheet name will be different each time the .csv is exported. Can someone look over my code and let me know if you see anything that stands out that would be screwing things up.

The code works up until Target.Copy (the target range is selected and copied). But the code I have to paste the values to the destination workbook don't seem to be working however.

I will sometimes get this error message: enter image description here 

Sub Opencsv()
Dim FilesToOpen
Dim wkbTemp As Workbook, wkbDest As Workbook
Dim sh As Worksheet
Dim Last As Long
Dim Target As Range
Dim LastRow As Long, LastCol As Long

FilesToOpen = Application.GetOpenFilename(Title:="Text Files to Open")
On Error Resume Next
Last = fLastRow(wkbDest)
Set wkbTemp = Workbooks.Open(filename:=FilesToOpen, Format:=4)
Set wkbDest = ThisWorkbook.Worksheets("AdvFilter")


With wkbTemp.Sheets(1)
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    LastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set Target = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

Target.Copy

wkbDest.Sheets("AdvFilter").Activate

With wkbDest.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

wkbTemp.Close
End Sub

'==================
Function fLastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

Update2:

Sub Opencsv2()
    Dim FilesToOpen
    Dim qt As QueryTable
    Dim Last As Long


FilesToOpen = Application.GetOpenFilename(Title:="Text Files to Open")


With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & FilesToOpen, Destination:=Cells(Last + 1, "A"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

For Each qt In ThisWorkbook.Sheets("AdvFilter").QueryTables
       qt.Delete
Next qt
End Sub

Upvotes: 1

Views: 1472

Answers (1)

Parfait
Parfait

Reputation: 107577

Consider importing using QueryTables and avoid any need for copy/paste to the clipboard:

Sub Opencsv()
   Dim FilesToOpen
   Dim qt As QueryTable

   FilesToOpen = Application.GetOpenFilename(Title:="Text Files to Open")

   With ThisWorkbook.Sheets("AdvFilter").QueryTables.Add(Connection:="TEXT;" & FilesToOpen, _
       Destination:=Cells(1, 1))
        .TextFileStartRow = 30
        .TextFileParseType = xlDelimited
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .Refresh BackgroundQuery:=False
   End With

   For Each qt In ThisWorkbook.Sheets("AdvFilter").QueryTables
       qt.Delete
   Next qt

End Sub

Upvotes: 2

Related Questions