从多个工作簿复制工作表数据并按工作表将其粘贴到主数据文件中

Question

我是 VBA 的新手，但是我被赋予了使用 VBA 完成的任务。如何创建一个代码，通过将完全相同数量的单独工作表添加到此主数据文件中，从不同工作簿复制多个工作表的数据并将它们粘贴到另一个工作簿（主数据文件）？也就是说，我想在主数据文件中显示所有这些工作表被复制到单独的工作表中。

我已经设法提取了一个代码，该代码将数据复制并粘贴到一个工作表中，但我正在努力将它们一一复制到单独的工作表中。

非常感谢您的帮助。

Sub datatransfer()

    Dim FolderPath, FilePath, Filename, targetfile As String
    Dim wb1, wb2 As Workbook
    Dim i, mycount As Long

    targetfile = "Left the location out on purpose"
    FolderPath = " Left the location out on purpose "
    FilePath = FolderPath & "*.xls*"

    Filename = Dir(FilePath)

    Dim lastrow, lastcolumn As Long

    Do While Filename < ""

        mycount = mycount + 1

        Filename = Dir()

        Set wb1 = Workbooks.Open(FolderPath & Filename)

        lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

        lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

        Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy

        Application.DisplayAlerts = False

        Set wb2 = Workbooks.Open(targetfile)

        Worksheets.Add Before:=Sheet1, Count:=2


        For i = 1 To mycount

            With Worksheets(i)

                ActiveSheet.Paste Destination:=.Range(Cells(2, 2), Cells(2, lastcolumn))

            End With

        Next i

        ActiveWorkbook.Close SaveChanges:=True

        Filename = Dir

    Loop

End Sub

Answer 1

请参阅下面的代码。我做了一些笔记，我对代码进行了一些修改，以确保它能够在未来顺利运行。

Sub datatransfer()

    'have to specify type for all variables, techinically it still works the way you did, but you are setting unncessary memory
    Dim FolderPath As String, FilePath As String, Filename As String, targetfile As String
    Dim wb1 As Workbook, wb2 As Workbook

    targetfile = "Left the location out on purpose"
    FolderPath = " Left the location out on purpose "
    FilePath = FolderPath & "*.xls*"

    Set wb2 = Workbooks.Open(targetfile) 'only need to open this once and leave open until execution is finished

    Filename = Dir(FilePath)

    Do While Filename <> "" ' need "<>" to say not equal to nothing

        wb2.Worksheets.Add After:=wb2.Worksheets(wb2.Worksheets.Count) 'add new sheet to paste data in target book

        Set wb1 = Workbooks.Open(FolderPath & Filename)

        Dim lastrow As Long, lastcolumn As Long

        With wb1.Worksheets(1) 'best to qualify all objects and work directly with them
            lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
            lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column

            'pretty sure you want to add this A1, since it's a new blank sheet
            .Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
                Destination:=wb2.Worksheets(wb2.Worksheets.Count).Range("A1")

        End With

        wb1.Close False 'assume no need to save changes to workbook you copied data from

        Filename = Dir

    Loop

    wb2.Close True 'no close and save master file

End Sub