こんにちは、ユーキです。
複数ファイルを１つのファイルにまとめるマクロを紹介します。
仕様
今回、作成する機能は以下になります。
- 読み込むフォルダは1か所を指定する
- 読み込みフォルダ内の対象ファイルは複数存在する
- 読み込み対象ファイルの拡張子は「.xlsx」のみとする
- 読み込んだ結果を出力先は新規ファイルとし、保存は行わない
複数ファイルを1ファイルにまとめるマクロの作成
それでは早速、複数ファイルを1ファイルにまとめるマクロを作成を作成していきましょう。
ファイルの一覧を作成する
まずはファイルの一覧を作成する機能を作成します。
作成するのは、以下の機能です。
- 指定フォルダからファイルの一覧を読み込む
- 読み込むファイルは「.xlsx」だけにする
- 対象フォルダを指定できるようにする
- 実行ボタンを追加する
指定フォルダからファイルの一覧を読み込む
指定パスからファイルの一覧を作成する処理を書きます。
ファイルの一覧取得は下記の記事を参考にします。
Public Sub FileList()
Dim rowIdx As Long
Dim path As String
Dim fs As Object
Dim f As Object
path = "C:\Temp"
Set fs = CreateObject("Scripting.FileSystemObject")
'先頭行を設定。10行目からスターとするようにします。
rowIdx = 10
For Each f In fs.GetFolder(path).Files
ActiveSheet.Cells(rowIdx, 2).Value = f.path 'B列にフルパスを表示
rowIdx = rowIdx + 1
Next f
End Subこの処理はボタン押下時イベントから呼び出しをするため、標準モジュールに記載をします。
読み込むファイルは「.xlsx」だけにする
指定フォルダ内のファイルに画像ファイルなどがある場合も考慮をして、拡張子が「.xlsx」のファイルだけが対象となるようにします。
拡張子の取得は、Scripting.FileSystemObjectのGetExtensionNameメソッドを使用します。
If fs.GetExtensionName(f.path) = "xlsx" Then
End If対象フォルダを指定できるようにする
読み込み対象のフォルダを指定できないと使い勝手が悪いので、パスを指定できるようにします。
パスの入力は、C2セルから値を読み込むようにします。
path = ActiveSheet.Cells(2, 3).ValueFileList関数の全体は次のようになります。
Public Sub FileList()
Dim rowIdx As Long
Dim path As String
Dim fs As Object
Dim f As Object
path = ActiveSheet.Cells(2, 3).Value
Set fs = CreateObject("Scripting.FileSystemObject")
'先頭行を設定。10行目からスターとするようにします。
rowIdx = 10
For Each f In fs.GetFolder(path).Files
If fs.GetExtensionName(f.path) = "xlsx" Then
ActiveSheet.Cells(rowIdx, 2).Value = f.path 'B列にフルパスを表示
rowIdx = rowIdx + 1
End If
Next f
End Sub実行ボタンを追加する
ファイルの一覧が取得できるようになったので、実行ボタンを追加しておきましょう。
ボタンの追加方法は以下の記事を参考にします。
ボタンの名前は「btnExec」としました。
先ほど作成したファイルの一覧取得処理をボタン押下時に呼び出すようにします。
Private Sub btnExec_Click()
Call FileList
End Subこれでボタン押下すると、指定したフォルダのファイル一覧が取得できるようになります。
１ファイルにまとめる
ファイルの一覧が作成できるようになったので、ここからは1ファイルにまとめる処理を書いていきます。
作成する機能は、以下になります。
- 新規ブックを作成する
- ファイル一覧のファイルを１つずつ処理する（ループ処理）
- 対象ファイルを読み取り専用で開く
- ファイルを読み取る
- 読み取った内容をまとめファイルへ転記する
- 関数として処理をまとめる
新規ブックを作成する
まずは１つにまとめるブックを新規で作成します。新規ブックは「Workbooks.Add」で作成が可能です。
このブックはあとで使うので、変数に設定しておきます。
Dim newWb As Workbook
Set newWb = Workbooks.Addファイル一覧のファイルを１つずつ処理する（ループ処理）
作成したファイル一覧からファイルを１ファイルずつ開いて読み込んでいきます。
繰り返し（ループ）処理を使って実装をします。対象ファイルが何件になるかがわからないので、読み込むファイルがなくなった時点で終了です。
while文でファイル名が空白になったところで処理を終了するように実装します。
while文の使い方は以下の記事を参考にしてください。
Dim fileCnt As Integer
fileCnt = 0
While ActiveSheet.Cells(10 + fileCnt, 2).Value <> ""
fileCnt = fileCnt + 1
Wend対象ファイルを読み取り専用で開く
では、対象ファイルを開きましょう。ファイルの更新が不要なので、ファイルは読み取り専用で開くことにします。
Dim readWb As Workbook
'ファイルを読み取り専用で開く
Set readWb = Workbooks.Open(ActiveSheet.Cells(10 + fileCnt, 2).Value, ReadOnly:=True)ファイルを読み取る
開いたファイルを読みこんで、コピーする処理を書きます。コピー対象は最初のシートのみとします。
シートの対象範囲はUsedRangeプロパティを使って指定します。対象するシートは1シートのみとします。
複数シートがある場合、選択→コピー→貼り付けを繰り返しましょう。
readWb.Sheets(1).UsedRange.Select
readWb.Sheets(1).UsedRange.Copy読み取った内容をまとめファイルへ転記する
読み取った内容をまとめファイルへ貼り付けます。
引数Destinationには、貼り付け位置を指定します。複数ファイルを読み込むので、読み込んだ行数を追加していく必要があるため、変数にします。貼り付けが完了したら張り付けた行数を加算します。
ファイルを閉じる際に「クリップボードに大きな値があります」というダイアログを出さないように、CutCopyModeをFalseに設定します。
newWb.Sheets(1).Paste Destination:=newWb.Sheets(1).Range("A" & rowIdx)
readWb.Application.CutCopyMode = False
rowIdx = rowIdx + readWb.Sheets(1).UsedRange.Rows.Countここまでの処理を関数にまとめる
ここまで書いてきた処理を関数にしましょう。引数にはファイル一覧があるシート(マクロ本体)を受け取れるようWorksheetを定義しておきます。
ファイル一覧があるシートを引数で指定するのは、様々なシートを扱うため、確実に対象シートにアクセスするためとなります。
Private Sub CombineFiles(sh As Worksheet)
Dim cnt As Long
Dim rowIdx As Long
Dim readWb As Workbook
Dim newWb As Workbook
cnt = 0
rowIdx = 1
While sh.Cells(10 + cnt, 2).Value <> ""
If cnt = 0 Then
Set newWb = Workbooks.Add
'新規Workbookを作成する
End If
'ファイルを読み取り専用で開く
Set readWb = Workbooks.Open(sh.Cells(10 + cnt, 2).Value, ReadOnly:=True)
readWb.Sheets(1).UsedRange.Select
readWb.Sheets(1).UsedRange.Copy
'転記
newWb.Sheets(1).Paste Destination:=newWb.Sheets(1).Range("A" & rowIdx)
readWb.Application.CutCopyMode = False
rowIdx = rowIdx + readWb.Sheets(1).UsedRange.Rows.Count
readWb.Close
cnt = cnt + 1
Wend
End Sub
これをファイル一覧作成終わった後で呼び出すようにします。これで完成となります。
完成コード
作成したコードの全文になります。
Private Sub btnExec_Click()
Call FileList
End Sub以下はすべて標準モジュールに記載をします。
Public Sub FileList()
Dim rowIdx As Long
Dim path As String
Dim fs As Object
Dim f As Object
path = ActiveSheet.Cells(2, 3).Value
Set fs = CreateObject("Scripting.FileSystemObject")
'先頭行を設定。10行目からスターとするようにします。
rowIdx = 10
For Each f In fs.GetFolder(path).Files
If fs.GetExtensionName(f.path) = "xlsx" Then
ActiveSheet.Cells(rowIdx, 2).Value = f.path 'B列にフルパスを表示
rowIdx = rowIdx + 1
End If
Next f
'ファイルを読み取り専用で開いて転記をする
Call CombineFiles(ActiveSheet)
End SubPrivate Sub CombineFiles(sh As Worksheet)
Dim cnt As Long
Dim rowIdx As Long
Dim readWb As Workbook
Dim newWb As Workbook
cnt = 0
rowIdx = 1
While sh.Cells(10 + cnt, 2).Value <> ""
If cnt = 0 Then
Set newWb = Workbooks.Add
'新規Workbookを作成する
End If
'ファイルを読み取り専用で開く
Set readWb = Workbooks.Open(sh.Cells(10 + cnt, 2).Value, ReadOnly:=True)
readWb.Sheets(1).UsedRange.Select
readWb.Sheets(1).UsedRange.Copy
'転記
newWb.Sheets(1).Paste Destination:=newWb.Sheets(1).Range("A" & rowIdx)
readWb.Application.CutCopyMode = False
rowIdx = rowIdx + readWb.Sheets(1).UsedRange.Rows.Count
readWb.Close
cnt = cnt + 1
Wend
End Subまとめ
今回は、複数ファイルを1ファイルにまとめるマクロを作成方法を紹介しました。
それほど難しい処理はないので、手順がわかれば簡単に作成できます。やり方はいろいろあるので、今回した紹介が正解ということはありません。自分が理解できるやり方で実装できればOKです。
実行した主なポイントは以下の通りです。
- ファイルの一覧作成は、Scripting.FileSystemObjectを使う
- ボタンを追加して、作成処理を呼び出す
- ファイルの読み込みは1ファイルずつ行う
- まとめファイルへはコピー＆ペーストで実行する
今回した方法は最低限のやり方です。コピーの形式を変更したい、対象ファイルに詳細条件を追加したい、エラー発生時にメッセージを出したいなどの処理は必要に応じて追加をしてください。
少しでもお役に立てば、幸いです。
スポンサーリンク
