Excel VBA マクロ あるフォルダー内の複数のファイルを統合したいです

大変お世話になっております。

●あるフォルダー内の複数のファイルを1つのファイル統合したいです。
1）複数のファイルのファイル名は異なります。
2）複数のファイルの各々のシート名は同一です。
3）複数ファイルの形式は同一です。
4）一つに統合した際に、シート名・形式を保ったままにしたいです。

現在は…
フォルダー内のファイルを一度各シートにし、その後、統合するVBAを使用しています。
統合した際に形式が保てませんし、2度手間になっています…。

■１■まず…以下を行い

Sub フォルダー内のファイルを各シートへまとめる()

Dim Filename As String
Dim IsBookOpen As Boolean
Dim OpenBook As Workbook
Dim ShCount As Long

With CreateObject("WScript.Shell")

.CurrentDirectory = "F:\2024.02.19_複数ファイルを一つにまとめる\新しいフォルダー" 'ここで読み込むフォルダを直接指定するF:\2022.12.01_複数ファイルを一つにまとめる

End With

Filename = Dir("*.xlsx")

Do While Filename <> ""

If Filename <> ThisWorkbook.Name Then

IsBookOpen = False

For Each OpenBook In Workbooks

If OpenBook.Name = Filename Then

IsBookOpen = True

Exit For

End If

Next

If IsBookOpen = False Then

ShCount = ThisWorkbook.Worksheets.Count

Workbooks.Open (Filename), UpdateLinks:=1

Worksheets.Copy after:=ThisWorkbook.Worksheets(ShCount)

Workbooks(Filename).Close savechanges:=False

End If

End If

Filename = Dir()

Loop

End Sub

■2■次に以下を行い…

Sub 複数のシートを1つのシートにまとめる()

Dim i As Long
Dim R As Long
Dim s As Long
Dim Sh As Worksheet
Dim MaxRow As Long
Dim MaxCol As Long
Dim MyArray As Variant
Dim JoinSh As Worksheet

Application.DisplayAlerts = False 'シート削除時のアラート停止

For Each Sh In Worksheets

If InStr(Sh.Name, "統合") <> 0 Then Sh.Delete 'すでに統合シートが存在する場合は一旦削除

Next

Application.DisplayAlerts = True 'シート削除時のアラート停止を解除

s = 1 '最大行を超えた場合次の統合シートを作成するための番号

Worksheets.Add Before:=Worksheets(s) '新規に統合シートを追加
ActiveSheet.Name = "統合"

Set JoinSh = ActiveSheet '統合シートを変数に格納

For i = s + 1 To Worksheets.Count 'シートを統合シートの次～末尾までループ

With Worksheets(i) '各月シート

If i = 2 Then

R = 1 '最初だけ項目も取得

Else

R = 2 '最初以外は2行目から取得

End If

MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row '1列目で最終行を取得
MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column '1行目で最終列を取得

MyArray = Range(.Cells(R, 1), .Cells(MaxRow, MaxCol)) 'A1～データ末尾まで配列に格納

End With

With JoinSh '統合シート

MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row '統合シートの１列目で最終行取得

If MaxRow + UBound(MyArray) > Rows.Count Then '最大行を超える場合の処理

s = s + 1 '統合シートの番号を加算

Worksheets.Add Before:=Worksheets(s) '新規に統合シートを追加
ActiveSheet.Name = "統合" & s '名前が同じにならないように番号を追加

Set JoinSh = ActiveSheet '統合シートを変数に格納
MaxRow = JoinSh.Cells(Rows.Count, 1).End(xlUp).Row '統合シートの１列目で最終行取得

End If

If .Cells(1, 1) = "" Then
'最初だけ1行目から貼り付け
Range(.Cells(1, 1), .Cells(UBound(MyArray), MaxCol)) = MyArray

Else
'最初以外は最終行の次に貼り付け
Range(.Cells(MaxRow + 1, 1), .Cells(MaxRow + UBound(MyArray), MaxCol)) = MyArray

End If

End With

Next i

End Sub

■3■最後に…、手作業で形式をコピーし、統合したファイルにペーストしています。

一度で解決するVBAをお教えいただけると本当に有難い限りです…。
お手数ですが、ご回答を心よりお待ちしております。
大変恐縮ですが、どうぞ宜しくお願い申し上げます。

No.1 ベストアンサー 回答者： fujillin 回答日時： 2024/02/20 11:40

こんにちは。

＞■3■最後に…、手作業で形式をコピーし、統合した
＞ファイルにペーストしています。
雰囲気からすると固定の書式のようですので、「マクロの記録」を利用すればほぼそのまま使えるマクロを作成可能であろうと想像します。
それができれば・・

＞一度で解決するVBAをお教えいただけると本当に有難い限りです…。
　Sub 一度で解決()
　　　Call Sub1
　　　Call Sub2
　　　Call Sub3
　End Sub
のように、各マクロを順に実行するマクロを作成しておいて、こちらを呼び出せば一度でできるようになるでしょう。


実態がさっぱりわかりませんけれど、固定書式であるなら、予めひな形のシートを作成しておいて（←邪魔なら非表示でも可）、新しいシートを作成する代わりにひな形をコピーするようにすれば、書式の設定も不要になりますし、タイトル行もあらかじめセットしておけば、タイトル行を気にする必要もなくなるでしょう。

この回答へのお礼

fujillin 様!
お忙しい中、ご回答をしていただきまして本当に有難うございました!
ご提示をくださいましたコードを、今使わせていただきました…!
大変便利なコードです!!

お陰様で、一度で解決出来そうではあるのですが、少し調整が必要です…。
（自身で記載したコードを変更した所、シート名で不具合が発生してしまいました…。こちらの問題ですので検証してみます…。）

「マクロの記録」にて手作業で形式をコピーも出来そうですが、こちらも調整が必要ですので、再度試してみます…!
本当に有難うございます…!

また質問をさせていただくと思います…。
その際にもどうか宜しくお願い致します…!

ご教示いただきまして、深く感謝申し上げます…!
大変恐縮ですが、次回以降も是非宜しくお願い申し上げます…!

お礼日時：2024/02/20 20:03