フォルダ内にある複数エクセルブックを一つにまとめたい

質問

マクロを使って複数ブックを一つにマージしたいです。
どなたか宜しくお願いします。

フォルダに１６個のエクセルブックがあります。ブックは４つのシートでできています。シートの列数は共通なのですが、行数が異なります。
これを新しいブックにコピペでつなげていきたいのです。

すみませんがどなたか宜しくお願いします。

回答No.1

rivoisu

いろいろな場面を想定したら結構長くなってしまいました。
一応コメントを読めばわかるとは思います。
Sub シート集約()
　　Dim i As Long
　　Dim 初期シート数 As Long
　　Dim 対象フォルダ As String
　　Dim Bname As String
　　Dim 転送先最終 As Long
　　Dim 転送元最終 As Long
　　Dim 最終列 As Long
　　Dim 転送先sheet As Worksheet
　　Dim 転送先Book As Workbook
　　Dim 転送元sheet As Worksheet
　　Dim 転送元Book As Workbook
　　Dim シート有無 As Boolean
　　'新しいBookを用意します。ここに集約して保存します。
　　Workbooks.Add
　　Set 転送先Book = ActiveWorkbook　'新しいBookを転送先Bookとする
　　初期シート数 = Sheets.Count
　　'新しいBook の最初のシート名を変更します。(ダブらないように)
　　For i = 1 To 初期シート数
　　　　Worksheets(i).Name = "qq" & i
　　Next
　　対象フォルダ = "C:\VBAtest"　　 '対象ファイルのあるフォルダー
　　Bname = Dir(対象フォルダ & "\" & "*.xls")　 '最初のExcelファイル名を取得
　　While Bname <> ""　　　　　　　　　　　　　 'ファイル名が空白になったら終了
　　　　Workbooks.Open (対象フォルダ & "\" & Bname)　 '対象ファイルを開く
　　　　Set 転送元Book = ActiveWorkbook　　　　　　　 '対象ファイルを転送元Bookとする
　　　　For Each 転送元sheet In 転送元Book.Worksheets '転送元Bookの全てにシートをひとつづつ
　　　　 '以下Nextまで　同じ名前のシートが転送先にあるかcheck
　　　　　　シート有無 = False
　　　　　　For Each 転送先sheet In 転送先Book.Worksheets
　　　　　　　　If 転送元sheet.Name = 転送先sheet.Name Then
　　　　　　　　　　　　シート有無 = True
　　　　　　　　End If
　　　　　　Next
　　　　　　If シート有無 = True Then
　　　　　　　　　　' シートがあるときの処理　　範囲指定してCopy
　　　　　　　　　　Set 転送先sheet = 転送先Book.Worksheets(転送元sheet.Name)
　　　　　　　　　　転送先最終 = 転送先sheet.Cells(Rows.Count, 1).End(xlUp).Row　'転送先シートの最終行
　　　　　　　　　　転送元最終 = 転送元sheet.Cells(Rows.Count, 1).End(xlUp).Row　'転送元シートの最終行
　　　　　　　　　　最終列 = 転送元sheet.Cells(1, Columns.Count).End(xlToLeft).Column　'最終転送列
　　　　　　　　　　転送元sheet.Activate
　　　　　　　　　　'転送範囲をCopy
　　　　　　　　　　転送元sheet.Range(Cells(2, 1), Cells(転送元最終, 最終列)).Copy _
　　　　　　　　　　　　　　Destination:=転送先sheet.Cells(転送先最終 + 1, 1)
　　　　　　　　Else
　　　　　　　　　　'シートのCopy
　　　　　　　　　　転送元sheet.Copy After:=転送先Book.Sheets(転送先Book.Sheets.Count)
　　　　　　End If
　　　　Next
　　　　転送元Book.Close　'処理が終わったファイルをclose
　　　　Bname = Dir()　　'次のExcelファイル名を取得
　　Wend
　　Application.DisplayAlerts = False　'シートの削除と保存に確認メッセージを出さない
　　For i = 1 To 初期シート数　　　　　'初期シートは不要なので削除
　　　　Worksheets(i).Delete
　　Next
　　転送先Book.SaveAs 対象フォルダ & "\Sumsheet.xls"　　'対象ファイルのフォルダーに保存
　　転送先Book.Close　　　　　　　　　　　　　　　　　　'Close
　　Application.DisplayAlerts = True　　'[シートの削除と保存に確認メッセージを出さない]を元に
End Sub
テストするときはフォルダーのバックアップをしてくださいね。
対象のフォルダーにまとめたファイルもできますのでそのまま2回実行すると
変になりますからご注意。
わからないことがありましたらどうぞ