将数据从多个工作簿中的多个工作表复制到单个主工作簿中

Question

我对宏是新手，需要帮助。我在一个文件夹中有几个工作簿，每个工作簿有四个工作表。现在我想要一个mocro它复制数据从每个工作簿（工作表明智）和过去在我的主工作簿（工作表明智）意味着数据1应该被粘贴一个在另一个下面在我的主工作簿在工作表1和工作表2分别。*工作簿名称可以是文件夹中的任何东西。有人能帮我完成整个代码吗？我有宏从一张表到我分配的表的数据，但它复制粘贴数据从打开的表，而不是按表名明智的。有人能帮我更正下面的代码吗：

Sub Ref_Doc_Collation()
Dim MyFile As String
Dim erow
Dim Filepath As String
Application.ScreenUpdating = False
Filepath = "\\NAMDFS\TPA\MWD\USERS\ay86009\Referral_Doc\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Referral_Doc_Collation.xlsm" Then
Exit Sub
End If

Workbooks.Open (Filepath & MyFile)
Sheets("Allocation").Range("B2:L3000").Copy
Application.DisplayAlerts = False

erow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Allocation").Range(Cells(erow, 2), Cells(erow, 12))

activesheet.next.select

Sheets("Prefetcher").Range("B2:I3000").Copy
Application.DisplayAlerts = False

erow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Prefetcher").Range(Cells(erow, 2), Cells(erow, 9))

activesheet.next.select

Sheets("Matrix").Range("B2:G3000").Copy
Application.DisplayAlerts = False

erow = Sheet3.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Matrix").Range(Cells(erow, 2), Cells(erow, 7))

activesheet.next.select

Sheets("Follow ups").Range("B2:H3000").Copy
Application.DisplayAlerts = False

erow = Sheet4.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Follow ups").Range(Cells(erow, 2), Cells(erow, 8))


ActiveWorkbook.Close
MyFile = Dir

Loop
Application.ScreenUpdating = True
MsgBox "DONE"
End Sub

Answer 1

已编译但未测试：

Sub Ref_Doc_Collation()

    Const FILE_PATH As String = "\\NAMDFS\TPA\MWD\USERS\ay86009\Referral_Doc\"
    Const SKIP_FILE As String = "Referral_Doc_Collation.xlsm"

    Dim MyFile As String, wb As Workbook

    Application.ScreenUpdating = False

    MyFile = Dir(FILE_PATH)

    Do While Len(MyFile) > 0

        If MyFile <> SKIP_FILE Then

            Set wb = Workbooks.Open(FILE_PATH & MyFile)

            wb.Sheets("Allocation").Range("B2:L3000").Copy _
                ThisWorkbook.Sheets("Allocation").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Sheets("Prefetcher").Range("B2:I3000").Copy _
                ThisWorkbook.Sheets("Prefetcher").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Sheets("Matrix").Range("B2:G3000").Copy _
                ThisWorkbook.Sheets("Matrix").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Sheets("Follow ups").Range("B2:H3000").Copy _
                ThisWorkbook.Sheets("Allocation").Cells(Rows.Count, "B"). _
                   End(xlUp).Offset(1, 0)

            wb.Close False

        End If

        MyFile = Dir

    Loop

    Application.ScreenUpdating = True
    MsgBox "DONE"

End Sub