Question

我无法将复制的范围粘贴到目标工作簿中。我有一个.csv文件，它有一个工作表，但每次导出.csv时工作表名称都不同。有人可以查看我的代码并让我知道，如果你看到任何突出的东西会搞砸了。

代码一直工作到Target.Copy（选择并复制目标范围）。但是，我必须将值粘贴到目标工作簿的代码似乎不起作用。

我有时会收到此错误消息：

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

Answer 1

考虑使用QueryTables导入，并且无需复制/粘贴到剪贴板：

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

打开CSV，将粘贴范围复制到工作簿

1 个答案: