将多个工作簿复制到单个工作簿中 "you cannot paste here because the copy area vba"

Question

我正在尝试使用 filedialog 方法打开所有选定的文件，然后将选定路径内的所有内容复制到当前工作簿。第一个路径文件成功复制了所有内容，到第二个时，报错：

"you cannot paste here because the copy area, select just one cell in the paste area etc."

下面是我的代码：

Sub Select_File_Click()
Dim lngCount As Long
    Dim cl As Range
    Dim c2 As Range
    Dim ItemType As String

    ThisWorkbook.Sheets("Sheet1").Range("A:D").ClearContents
    Set cl = ActiveSheet.Cells(1, 3)
    ' Open the file dialog
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "comma-separated values", "*.csv"
        .InitialFileName = "*" & ItemType & "*.*"
        .InitialView = msoFileDialogViewDetails
        .Show
        For lngCount = 1 To .SelectedItems.Count

            ' Add Hyperlinks
            cl.Worksheet.Hyperlinks.Add _
            Anchor:=cl, Address:=.SelectedItems(lngCount), _
                TextToDisplay:=.SelectedItems(lngCount)
            ' Add file name
            'cl.Offset(0, 1) = _
            '    Mid(.SelectedItems(lngCount), InStrRev(.SelectedItems(lngCount), "\") + 1)
            ' Add file as formula
            cl.Offset(0, 1).FormulaR1C1 = _
                 "=TRIM(RIGHT(SUBSTITUTE(RC[-1],""\"",REPT("" "",99)),99))"


            Set cl = cl.Offset(1, 0)
            Set c2 = cl.Offset(0, 1)
        Next lngCount
        Sheets(1).Cells(1, 1) = .SelectedItems.Count

End With
End Sub

Sub All_data_Click()
Dim Count As Integer
Dim iLast As Long

ThisWorkbook.Sheets("Copy").Range("A1:AZ5000").ClearContents
Count = ThisWorkbook.Sheets(1).Cells(1, 1)
iLast = 1

For i = 1 To Count
pth = ThisWorkbook.Sheets("Sheet1").Cells(i, 3).Value 'Select folder path
Set LookupWB = Workbooks.Open(Filename:=pth)
Set sourceColumn1 = ThisWorkbook.Sheets("Copy")
Set Source = ActiveWorkbook.Sheets(1)
Set sourceColumn1 = Source.Columns("A:AZ")
Set targetColumn1 = ThisWorkbook.Worksheets("Copy").Rows(iLast)
sourceColumn1.Copy Destination:=targetColumn1   <---Error Here: 
iLast = iLast + sourceColumn1.Range("A" & Rows.Count).End(xlUp).Row
Next i


End Sub

有什么办法可以解决这个问题吗？我已经迷路了。

Answer 1

如果我正确理解了您要尝试做的事情，我建议一次性使用稍微不同的方法：

Sub Select_File_Click()
    Dim Wb As Workbook: Set Wb = ThisWorkbook
    Dim Sh1 As Worksheet: Set Sh1 = Wb.Sheets("Sheet1")
    Dim Sh2 As Worksheet: Set Sh2 = Wb.Sheets("Copy")
    Dim i As Integer, Cnt As Integer
    Dim Wbt As Workbook

    Sh1.Range("A:D").ClearContents
    Sh2.Cells.Clear
    Cnt = 1

    ' Open the file dialog
    With Application.FileDialog(msoFileDialogFilePicker) 'Using a file picker instead of open
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "comma-separated values", "*.csv"
        .InitialFileName = "*.*"
        .InitialView = msoFileDialogViewDetails
        .Show

        For i = 1 To .SelectedItems.Count

            'You dont actually need the 4 lines below if you only need to do the copy
            ' Add Hyperlinks
            Sh1.Cells(i, 3).Worksheet.Hyperlinks.Add Anchor:=Sh1.Cells(i, 3), Address:=.SelectedItems(i), TextToDisplay:=.SelectedItems(i)
            ' Add file as formula
            Sh1.Cells(i, 4).FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[-1],""\"",REPT("" "",99)),99))"

            Set Wbt = Workbooks.Open(.SelectedItems(i))
            Intersect(Wbt.Sheets(1).UsedRange, Wbt.Sheets(1).Columns("A:AZ")).Copy Sh2.Range("A" & Cnt)
            Cnt = Cnt + Intersect(Wbt.Sheets(1).UsedRange, Wbt.Sheets(1).Columns("A:AZ")).Rows.Count
            Wbt.Saved = True
            Wbt.Close
        Next i
    End With
End Sub

将多个工作簿复制到单个工作簿中 "you cannot paste here because the copy area vba"

Copy multiple workbook into single workbook "you cannot paste here because the copy area vba"

excel

vba

copy-paste