分割されているExcelファイルを一つに統合する
分割されている Excelファイルを一つにまとめるVBAアプリを紹介します。
今回のサンプルアプリは会社別に作成されているExcelファイルの表を一つの表にまとめるVBAです。
業務の中で部署別や会社別に作成されているExcelファイルの表をボタンを1クリックするだけで一つの表にすることができます。
複数に分かれているExcelファイルを一つのファイルにまとめる業務で活用してください。
サンプルコードの処理内容
「Excelファイル統合」ボタンをクリックすると、分割されているExcelファイルの表を読み込んで一つの表にまとめます。
分割ファイルＡ会社の内容
コードの解説
Excelファイルを一つにまとめるVBAの中心となるコードは以下の通りです。
分割ファイルの数だけループ処理させて、その間に分割ファイルのデータを統合するファイルにコピーします。
コピー処理が終わったらその都度開いた分割ファイルを閉じて、次のファイルのコピー作業に移ります。
'指定したフォルダにあるファイルの数だけループ
Do While myFile <> ""
'分割フィルをオブジェクトとして取得
Set wb = Workbooks.Open(myFile)
'分割ファイルデータの先頭行
i = 3
'データがなくなるところまでループ処理
Do While wb.Sheets("Sheet1").Cells(i, 2).Value <> ""
wa.Cells(start, 2) = wb.Sheets("Sheet1").Cells(i, 2) '会社名コピー
wa.Cells(start, 3) = wb.Sheets("Sheet1").Cells(i, 3) '注文番号コピー
wa.Cells(start, 4) = wb.Sheets("Sheet1").Cells(i, 4) '商品コピー
wa.Cells(start, 5) = wb.Sheets("Sheet1").Cells(i, 5) '数量コピー
wa.Cells(start, 6) = wb.Sheets("Sheet1").Cells(i, 6) '単価コピー
wa.Cells(start, 7) = wb.Sheets("Sheet1").Cells(i, 7) '金額コードコピー
i = i + 1 '分割ファイルの次のデータに移動
start = start + 1 '統合ファイルの次のデータ行に移動
Loop
'警告を出さず保存しないで読込先のファイルを終了
If Not (wb Is Nothing) Then
wb.Close (False)
End If
'読み込み終わった分割ファイルをクリア
Set wb = Nothing
'次のファイルを取得
myFile = Dir()
Loop
サンプルコード コードの作成手順はこちら
「ThisWorkbook.Path」でエラーが発生した場合、
下記リンク先に回避する方法を記載しましたので参照ください。
https://scodebank.com/?p=696
Option Explicit
Dim myDir As String '現在ファイルの保存フォルダ
Dim ReadFile As String '各読込み先ファイル
Dim chek As Integer 'ファイルが開いているかどうかのチェック変数
------------------------------------------------------------------------
Sub ExcelFile_Import()
Dim wa As Worksheet '読込み元「Sheet1」シート名を格納する変数
Dim wb As Workbook '読込み先ブック名を格納する変数（分割ファイル）
Dim fname As String '現在のブック名
Dim start, i As Long 'カウント用変数
'現在開いているブック名を取得
fname = ThisWorkbook.Name
'シート「Sheet1」を選択
Worksheets("Sheet1").Select
'シート「Sheet1」を変数「wa」にセット
Set wa = Worksheets("Sheet1")
'以下で同じフォルダに保存されている全ファイルを順番に読み込んでセルに転記
'読込み先ブック（分割ファイル）が開いていたら閉じる様に促し終了
Call OpenCheck '下に記載した「Sub OpenCheck()」の実行
'OpenCheckの結果、読み込み元ファイルが開いていたら処理終了
If chek = 1 Then '読込み先ファイルが開いていたらchekフラグに「1」がセットされているので一旦終了する
chek = 0 'chekフラグに「0」をセットして処理を終了
Exit Sub
End If
'読込み先ファイル名を取得
ReadFile = Dir(myDir & "\*.xls*")
'画面の更新を停止
Application.ScreenUpdating = False
'マウスモードを待ち状態に変更
Application.Cursor = xlWait
'統合ファイルの最初のデータ行を指定
start = 5
'指定したフォルダにあるファイルの数だけループ
Do While ReadFile <> ""
'統合ファイル名と違っている間はループ
If ReadFile <> fname Then
'分割フィルをオブジェクトとして取得
Set wb = Workbooks.Open(ReadFile)
i = 3 '分割ファイルデータの先頭行
Do While wb.Sheets("Sheet1").Cells(i, 2).Value <> "" 'データがなくなるところまでループ処理
wa.Cells(start, 2) = wb.Sheets("Sheet1").Cells(i, 2) '会社名コピー
wa.Cells(start, 3) = wb.Sheets("Sheet1").Cells(i, 3) '注文番号コピー
wa.Cells(start, 4) = wb.Sheets("Sheet1").Cells(i, 4) '商品コピー
wa.Cells(start, 5) = wb.Sheets("Sheet1").Cells(i, 5) '数量コピー
wa.Cells(start, 6) = wb.Sheets("Sheet1").Cells(i, 6) '単価コピー
wa.Cells(start, 7) = wb.Sheets("Sheet1").Cells(i, 7) '金額コードコピー
'Ｆ列Ｇ列の桁区切りの指定
wa.Range("F" & start & ":" & "G" & start).NumberFormatLocal = "#,###"
'表の罫線を引く
'水平線
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeBottom).LineStyle = xlContinuous
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeBottom).Weight = xlHairline
'左側線
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeLeft).LineStyle = xlContinuous
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeLeft).Weight = xlThin
'右側線
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeRight).LineStyle = xlContinuous
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeRight).Weight = xlThin
'垂直線
wa.Range("B" & start & ":" & "G" & start).Borders(xlInsideVertical).LineStyle = xlContinuous
wa.Range("B" & start & ":" & "G" & start).Borders(xlInsideVertical).Weight = xlThin
i = i + 1 '分割ファイルの次のデータに移動
start = start + 1 '統合ファイルの次のデータ行に移動
Loop
'会社間の水平区切り線(実線)を引く
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeTop).LineStyle = xlContinuous
wa.Range("B" & start & ":" & "G" & start).Borders(xlEdgeTop).Weight = xlThin
End If
'警告を出さず保存しないで読込先のファイルを終了
If Not (wb Is Nothing) Then
wb.Close (False)
End If
'読み込み終わった分割ファイルをクリア
Set wb = Nothing
'次のファイル名をReadFileにセット
ReadFile = Dir()
Loop
'画面更新を復活
Application.ScreenUpdating = True
'マウスのカーソルを通常モードに変更
Application.Cursor = xlDefault
'コピー先の列幅をデータ長に合わせる
Worksheets("Sheet1").Range("B:G").Columns.AutoFit
MsgBox "読込が完了しました。", vbOKOnly
End Sub
----------------------------------------------------------------------------
Sub OpenCheck()
'このブック以外のExcelが開かれているかチェック
Dim wb As Workbook
'作業フォルダを指定
myDir = ThisWorkbook.Path 'マクロ実行ファイルのフォルダのパス
ChDrive Left(myDir, 1) 'カレントドライブを変更
ChDir myDir 'カレントディレクトリを変更
'作業フォルダにあるエクセルファイルを取得
ReadFile = Dir(myDir & "\*.xls*")
'エクセルファイルがある間はループ
Do While ReadFile <> ""
'現在開いているブックの一覧を取得
For Each wb In Workbooks
'現在開いている分割ファイルがあったら閉じるようにメッセージを出す
If wb.Name = ReadFile And wb.Name <> ThisWorkbook.Name Then
MsgBox ReadFile & "を閉じてから実行してください。"
'読込み先ファイルがあったらchekフラグに「1」をセット
chek = 1
Exit Sub
End If
Next wb
ReadFile = Dir() '次のファイル名をmyfFileにセット
Loop
End Sub