同じ名前の異なるワークブックのシートをマスターワークブックに結合します

Question

したがって、約16枚のファイルにすべて同じ名前の約21枚のシートがあります。すべての書式などはまったく同じです。たとえば、すべての16枚のファイルの「年齢」を含むすべてのシートを、すべての「年齢」の集計データを含む「年齢」シートを持つマスターファイルに結合する必要があります。シート。他の20種類のシートについても同様です。

どのようにこれを正確に行うかわかりません。私は現在、ファイル内のすべてのシートを1つのマスターブックにまとめているマクロを持っています。これを変更して、すべてのブックを1つのブックに追加するのではなく、同様のシートを組み合わせています。 アイデアをいただければ幸いです！

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