如何将文件夹中多个 Excel 工作簿中的数据复制到主工作表中？

Question

我有一个“主文件”，我想从测试文件夹中的多个 Excel 工作簿中复制数据。
我制作了一个宏，它正在打开每个文件并粘贴到主文件中。

它每次都在主文件中创建一个单独的工作表。
我希望它在找到主文件的最后一行后将数据粘贴到同一张表中。

Copy to clipboard
Sub ConslidateWorkbooks1()
    Dim FolderPath As String
    Dim Filename As String
    Dim Sheet As Worksheet
    Application.ScreenUpdating = False
    FolderPath = Environ("userprofile") & "\Desktop\Carrier\Test\"
    Filename = Dir(FolderPath & "*.xls*")
    Do While Filename <> ""
        Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
        For Each Sheet In ActiveWorkbook.Sheets
            Sheet.Copy After:=ThisWorkbook.Sheets(1)
        Next Sheet
        Workbooks(Filename).Close
        Filename = Dir()
    Loop
    Application.ScreenUpdating = True
End Sub

Answer 1

我认为问题是Sheet.Copy After:=ThisWorkbook.Sheets(1) 。 如果您想粘贴到同一张表 - 在下一个可用行，那么您需要找出该行是什么。 以下代码未经测试，但应该给你你想要的。 让我知道你如何使用它 go。

Option Explicit
Sub ConslidateWorkbooks1()
Dim FolderPath As String, Filename As String, Sh As Worksheet, PasteToRow As Long
On Error GoTo GetOut

Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "\Desktop\Carrier\Test\"
Filename = Dir(FolderPath & "*.xls*")
PasteToRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1

Do While Filename <> ""
    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
    For Each Sh In ActiveWorkbook.Sheets
        'Sheet.Copy After:=ThisWorkbook.Sheets(1) '<~~ the line causing the problem
        Sh.Cells.Copy ThisWorkbook.Sheets(1).Range("A" & PasteToRow)
        PasteToRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
    Next Sh
    Workbooks(Filename).Close
    Filename = Dir()
Loop

GetOut:
    MsgBox Err.Description
    Application.ScreenUpdating = True
    Exit Sub

End Sub