複数のエクセルを1つのエクセルに

質問

複数のエクセルを1つのエクセルにしたいです。
また、1つのシートにそれぞれのエクセルファイルを追記でまとめたいです。
どのエクセルファイルも1行目はタイトル行となっています。
エクセルのファイル名は変えても問題ありません。
これはマクロで可能でしょうか？
他の方法がありましたら、教えてください。
よろしくお願いします。

回答No.1

Wendy02 · ベストアンサー

こんばんは。

時々、出てくる質問のような気がします。物理的なメモリの余裕などを度外視すれば、以下のようなコードで可能です。

ファイルを選択する時は、Ctrl キーを押しながら複数選ぶか、Shiftキーを押しながらファイルを複数選びます。コピーされたシート名は、一応、ファイルのベース名(.xlsの拡張子を取ったもの）とシート番号が付きます。

なお、統合ファイルは、最後に保存する時に、ファイル名を聞いてきますから、『拡張子を入れず』名前をつけてください。そして、このマクロを登録したブックのフォルダに作成されます。

なお、プロテクトされたブックは、選択しないでください。今のところ、その処理をしておりません。一応、何度も試験はしてみたものの、まだ、不具合があるかもしれませんから、何度かテストしてみてから本番に掛かってください。また、あまり巨大になるようでしたら、マクロの途中で不具合を起こすかもしれません。

'なるべく標準モジュールに登録してください
'------------------------------------
Sub BooksUnifying()
　 Dim FileNames As Variant
　 Dim fn As Variant
　 Dim i As Long
　 Dim j As Long
　 Dim NewBook As Workbook
　 Dim SheetsCount As Integer
　 Dim NewBookName As String
　 Dim buf As String
　 On Error Resume Next
　 'Ctrl キーを押しながらファイルを選ぶか、または、Shiftキーを押しながらファイルを選ぶ
　 FileNames = Application.GetOpenFilename( _
　 "Excel(*.xls),*.xls", Title:="ファイル選択", MultiSelect:=True)
　 If VarType(FileNames) = vbBoolean Then Exit Sub

　 SheetsCount = Application.SheetsInNewWorkbook
　 Application.SheetsInNewWorkbook = 1

　 Set NewBook = Workbooks.Add

　 On Error Resume Next
　 Application.ScreenUpdating = False
　 For Each fn In FileNames
　　　With Workbooks.Open(fn, ReadOnly:=True)
　　　　 For i = 1 To .Worksheets.Count
　　　　　　If WorksheetFunction.CountA(.Worksheets(i).Cells) > 0 Then
　　　　　　　 If j > 0 Then
　　　　　　　　　NewBook.Worksheets.Add After:=NewBook.Sheets(j)
　　　　　　　 End If

　　　　　　　 .Worksheets(i).Cells.Copy NewBook.ActiveSheet.Range("A1")
　　　　　　　 buf = Replace$(fn, Left$(fn, InStrRev(fn, "\")), "")
　　　　　　　 buf = Mid$(buf, 1, InStr(buf, ".") - 1)
　　　　　　　 NewBook.ActiveSheet.Name = buf & "-" & i
　　　　　　　 j = j + 1
　　　　　　End If
　　　　 Next i
　　　　 .Close False
　　　End With
　 Next fn
　 Application.ScreenUpdating = True
　 NewBookName = Application.InputBox("新規ブック名を付けてください。", Title:="新規ブック名", Type:=2)
　 If NewBookName <> "False" And NewBookName <> "" Then
　　　NewBookName = Replace$(NewBookName, ".xls", "", , , vbTextCompare)
　　　NewBook.SaveAs ThisWorkbook.Path & "\" & NewBookName
　 End If
　 Set NewBook = Nothing
　 ThisWorkbook.Activate
　 Application.SheetsInNewWorkbook = SheetsCount
End Sub

お礼

No.1さん、回答ありがございます。
教えてくれたマクロで僕が思っていたとおりに出来ました。
どうも有難うございます。うれしい限りです。