將來自不同工作簿的具有相同名稱的圖紙合並到主工作簿中

Question

所以我大約有21張紙，在大約16個文件中都被命名為完全相同。 所有格式都完全一樣，因此例如，我需要將所有16個文件中所有帶有“年齡”的工作表合並到一個主文件中，該主文件將具有“年齡”工作表以及所有16個“年齡”的匯總數據床單。 對於其他20種工作表類型也是如此。

我不確定該怎么做。 我有一個宏，當前可將文件中的所有工作表一起添加到一個主工作簿中，並且我正在尋求對其進行修改，以便它合並相似的工作表，而不是僅將它們全部添加到一個工作簿中。 任何想法，將不勝感激！

Sub AddAllWS()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

MyPath = "C:\Documents and Settings\path\to"
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)

If Len(strFilename) = 0 Then Exit Sub

Do Until strFilename = ""

        Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)

        Set wsSrc = wbSrc.Worksheets(1)

        wsSrc.UsedRange.Copy

        wsSrc.Paste (wbSrc.Range("A" & Rows.Count).End(xlUp).Offset(1))


        wbSrc.Close False

    strFilename = Dir()

Loop
wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Answer 1

您似乎正在復制並粘貼到同一源工作表中。 檢查下面的代碼。 那可能行得通。 我在代碼中添加了注釋。

Sub AddAllWS()
    Dim wbDst As Workbook
    Dim wsDst As Worksheet
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim MyPath As String
    Dim strFilename As String
    Dim lLastRow As Long

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set wbDst = ThisWorkbook

    MyPath = "C:\Documents and Settings\path\to\"
    strFilename = Dir(MyPath & "*.xls*", vbNormal)

    Do While strFilename <> ""

            Set wbSrc = Workbooks.Open(MyPath & strFilename)

            'loop through each worksheet in the source file
            For Each wsSrc In wbSrc.Worksheets
                'Find the corresponding worksheet in the destination with the same name as the source
                On Error Resume Next
                Set wsDst = wbDst.Worksheets(wsSrc.Name)
                On Error GoTo 0
                If wsDst.Name = wsSrc.Name Then
                    lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
                    wsSrc.UsedRange.Copy
                    wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
                End If
            Next wsSrc

            wbSrc.Close False
            strFilename = Dir()
    Loop

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub