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

Question

我是宏的新手，需要帮助。我的文件夹中的工作簿很少，每个工作簿都有四个工作表。现在我想要一个从每个工作簿复制数据（明智的工作表）和过去在我的主工作簿中的数据（明智的工作表）意味着工作表 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