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

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

1 个答案: