Ｅｘｃｅｌシートの統合するマクロなどがありましたらお教えください。

質問

各支店（約200）からExcelシートで送信されてくる報告内容を別のシートに一気にまとめるマクロ等はないでしょうか？ご存知の方よろしくお願いします。
（例）

Ａ支店　

項目　　aaa 　　 bbb 　　 ccc 　　 ddd 　　 eee
　　　　　　 10 　　 20 　　　 30 　　 0 　　　 0
　　　　　　　 8 　　 8 　　　　 0 　 　 0 　　　　 0
　　　　　　　 　　　　　　以下約300件
Ｂ支店　

項目　　aaa 　　 bbb 　　 ccc 　　 ddd 　　 eee
　　　　　　 11 　　 22 　　　 33 　　 0 　　　 0
　　　　　　　 9 　　 9 　　　　 0 　 　 0 　　　　 0
　　　　　　　 　　　　　　以下約300件

別シートに

項目　　aaa 　　 bbb 　　 ccc 　　 ddd 　　 eee
　　　　　　 10 　　 20 　　　 30 　　 0 　　　 0
　　　　　　　 8 　　 8 　　　　 0 　 　 0 　　　　 0
　　　　　　 11 　　 22 　　　 33 　　 0 　　　 0
　　　　　　　 9 　　 9 　　　　 0 　 　 0 　　　　 0

　　　以下省略　　　　　　　　　　　よろしくお願いします

回答No.1

merlionXX · ベストアンサー

各シートの配置が分からないので仮定でお答えします。

1.各支店から来たExcelシートは全て同じフォルダー内にあるものとします。
2.データはすべてSheet1という名前のシートにあるものとします。
3.項目行は1行目、データ行は2行目から下へ、A列には空白のない状態で並んでいるものとします。
4.データをまとめるファイルも同じフォルダー内に作成し、まとめる先のシート名はTOTALとします.
5.マクロ実行前にまとめるファイルはいったん保存してください。
6.TOTALシートの1行目には項目が入っているものとします。

以上の前提で以下のマクロを実行してください。

Sub Test01()
Application.ScreenUpdating = False
fldPath = ThisWorkbook.Path & "\"
fname = Dir(fldPath & "*.xls") 'フォルダ内のExcelファイルを検索
Do Until fname = Empty '全て検索し終えると、fname = Empty となるので、その間以下を実行
If fname <> ThisWorkbook.Name Then
Workbooks.Open fldPath & fname '選択したファイルを開きます
'mx = Application.WorksheetFunction.Max(Sheets("Sheet1").Columns(1)) 'Sheet1の最大値を取得

lr = Sheets("Sheet1").Range("A65536").End(xlUp).Row 'Sheet1の最終行を取得
fr = ThisWorkbook.Sheets("TOTAL").Range("A65536").End(xlUp).Row + 1 'Totalの開始行を取得

Sheets("Sheet1").Rows("2:" & lr).Copy 'Sheet1のデータ行（2行目以降）をコピー
Application.DisplayAlerts = False
ActiveWorkbook.Close (False) '閉じる
Application.DisplayAlerts = True
ThisWorkbook.Sheets("TOTAL").Cells(fr, 1).Select 'Totalの開始行を選択
ActiveSheet.Paste 'データ貼り付け
Application.CutCopyMode = False
End If
fname = Dir '選択したフォルダ内の次のExcelファイルを検索
Loop '繰り返す
Application.ScreenUpdating = True
End Sub