VBA100本ノック 93本目：複数ブックを連結して再分割

公開日：2021-02-22　最終更新日：2021-02-23

VBA100本ノック 93本目：複数ブックを連結して再分割

「月別」フォルダの年月別のファイルを集め、「支店別」フォルダに支店ファイルで出力する問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

#VBA100本ノック 93本目
「月別」フォルダには同一フォーマット（1シートのみ）の年月別のファイルがあります。
全データを集め、支店別に分割し直し「支店別」フォルダに「支店CD.xlsx」で出力してください。
フォーマットは画像及びサンプルファイルにて。
※「月別」「支店別」フォルダのパスは任意

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_93.zip

zipに、
202004.xlsx～202009.xlsx
以上の6ファイルが入っています。

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

復習をかねての総合問題の位置づけです。
フォルダ内のブックを集めるのはやりましたし、フィルタ等で分割もやってますので、それらを組み合わせれば完成します。
まずはDir関数を使ってフォルダ内ファイルを取得し、1ブックに集めてからオートフィルタを使って分割します。


  
    
      Sub VBA100_93_01()

　　Dim inPath As String:　 inPath = ThisWorkbook.Path & "\月別\"

　　Dim outPath As String:　outPath = ThisWorkbook.Path & "\支店別\"

　　Application.ScreenUpdating = False

　　Application.DisplayAlerts = False

　　

　　'作業用ブック作成

　　Dim wb As Workbook:　　 Set wb = Workbooks.Add

　　Dim ws1 As Worksheet:　 Set ws1 = wb.Worksheets.Add

　　Dim ws2 As Worksheet:　 Set ws2 = wb.Worksheets.Add

　　

　　'月別フォルダの全ファイルを連結

　　Dim wbR As Workbook, sFile As String, outRow As Long, offsetRow As Long

　　sFile = Dir(inPath)

　　Do While sFile <> ""

　　　　Set wbR = Workbooks.Open(Filename:=inPath & sFile, UpdateLinks:=0, ReadOnly:=True)

　　　　outRow = ws1.Range("A1").CurrentRegion.Rows.Count + offsetRow

　　　　wbR.Worksheets(1).UsedRange.Offset(offsetRow).Copy ws1.Cells(outRow, 1)

　　　　offsetRow = 1

　　　　wbR.Close SaveChanges:=False

　　　　sFile = Dir()

　　Loop

　　

　　'並べ替え&支店CDユニーク化

　　ws1.Range("A1").Sort key1:=ws1.Range("A1"), key2:=ws1.Range("C1"), Header:=xlYes

　　ws1.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Range("A1"), Unique:=True

　　

　　'出力用ブック作成

　　Dim i As Long

　　Dim outWb As Workbook: Set outWb = Workbooks.Add

　　For i = outWb.Worksheets.Count To 2 Step -1

　　　　outWb.Worksheets(i).Delete

　　Next

　　Dim outWs As Worksheet: Set outWs = outWb.Worksheets(1)

　　

　　'支店別ブック出力

　　If Dir(outPath, vbDirectory) = "" Then MkDir outPath '出力フォルダ作成

　　For i = 2 To ws2.Range("A1").CurrentRegion.Rows.Count

　　　　outWs.Cells.Clear

　　　　ws1.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=ws2.Cells(i, 1).Value

　　　　ws1.Range("A1").CurrentRegion.Copy outWs.Range("A1")

　　　　outWs.Name = ws2.Cells(i, 1).Value

　　　　outWb.SaveAs outPath & ws2.Cells(i, 1).Value & ".xlsx"

　　Next

　　outWb.Close SaveChanges:=False

　　wb.Close SaveChanges:=False

　　

　　Application.DisplayAlerts = True

　　Application.ScreenUpdating = True

　　MsgBox "支店別作成完了"

End Sub

記事補足では、先のVBAを変更して別プロセスで処理するようにしてみました。
基本的な流れは同じですが、
FSOに変更したりステータスバーへの進捗表示や件数表示を加えたりしました。
VBA記述はWithを多用した書き方にしてみました。ご参考まで。

補足

当然やっていることは先のVBAと同じものですが、大分雰囲気を変えたものにしてみました。
特に説明するような部分も無いと思います。
別プロセスで処理してはいても、見えているのは起動したVBA側になるので、ステータスバーの表示は起動側に出しています。


  
    
      Sub VBA100_93_02()

　　Dim inPath As String:　 inPath = ThisWorkbook.Path & "\月別"

　　Dim outPath As String:　outPath = ThisWorkbook.Path & "\支店別"

　　

　　Dim xlApp As New Excel.Application

　　Dim wb As Workbook:　　 Set wb = xlApp.Workbooks.Add

　　Dim ws1 As Worksheet:　 Set ws1 = wb.Worksheets.Add

　　Dim ws2 As Worksheet:　 Set ws2 = wb.Worksheets.Add

　　

　　Dim inCnt As Long, outCnt As Long

　　

　　inCnt = UnionBook(ws1, inPath)

　　Call SortAndUnique(ws1, ws2)

　　outCnt = DividBook(ws1, ws2, outPath)

　　

　　wb.Close SaveChanges:=False

　　xlApp.Quit

　　Set xlApp = Nothing

　　

　　Application.StatusBar = False

　　MsgBox "支店別作成完了" & vbLf & vbLf & _

　　　　　 "月別　：" & inCnt & "件" & vbLf & _

　　　　　 "支店別：" & outCnt & "件"

End Sub


Function UnionBook(ByVal ws1 As Worksheet, ByVal inPath As String)

　　Dim xlApp As Excel.Application: Set xlApp = ws1.Application

　　Dim inCnt As Long, inMaxCnt As Long

　　Dim oFile As Object, outRow As Long, offsetRow As Long

　　

　　With CreateObject("Scripting.FileSystemObject")

　　　　inMaxCnt = .GetFolder(inPath).Files.Count

　　　　For Each oFile In .GetFolder(inPath).Files

　　　　　　inCnt = inCnt + 1

　　　　　　Application.StatusBar = "ファイル読込中：" & inCnt & "/" & inMaxCnt: DoEvents

　　　　　　With xlApp.Workbooks.Open(Filename:=oFile.Path, UpdateLinks:=0, ReadOnly:=True)

　　　　　　　　outRow = ws1.Range("A1").CurrentRegion.Rows.Count + offsetRow

　　　　　　　　.Worksheets(1).UsedRange.Offset(offsetRow).Copy ws1.Cells(outRow, 1)

　　　　　　　　offsetRow = 1

　　　　　　　　.Close SaveChanges:=False

　　　　　　End With

　　　　Next

　　End With

　　UnionBook = inCnt

End Function


Function SortAndUnique(ByVal ws1 As Worksheet, ByVal ws2 As Worksheet)

　　Application.StatusBar = "支店で並べ替え&支店CDユニーク化": DoEvents

　　With ws1

　　　　.Range("A1").Sort key1:=.Range("A1"), key2:=.Range("C1"), Header:=xlYes

　　　　.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Range("A1"), Unique:=True

　　End With

End Function


Function DividBook(ByVal ws1 As Worksheet, ByVal ws2 As Worksheet, ByVal outPath As String) As Long

　　Dim xlApp As Excel.Application: Set xlApp = ws1.Application

　　xlApp.DisplayAlerts = False

　　

　　Dim i As Long, outCnt As Long, outMaxCnt As Long

　　Dim outWb As Workbook: Set outWb = xlApp.Workbooks.Add

　　

　　With CreateObject("Scripting.FileSystemObject")

　　　　If Not .FolderExists(outPath) Then Call .CreateFolder(outPath)

　　End With

　　For i = outWb.Worksheets.Count To 2 Step -1

　　　　outWb.Worksheets(i).Delete

　　Next

　　Dim outWs As Worksheet: Set outWs = outWb.Worksheets(1)

　　

　　outMaxCnt = ws2.Range("A1").CurrentRegion.Rows.Count - 1

　　For i = 2 To ws2.Range("A1").CurrentRegion.Rows.Count

　　　　outCnt = outCnt + 1

　　　　Application.StatusBar = "ファイル出力中：" & outCnt & "/" & outMaxCnt: DoEvents

　　　　outWs.Cells.Clear

　　　　ws1.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=ws2.Cells(i, 1).Value

　　　　ws1.Range("A1").CurrentRegion.Copy outWs.Range("A1")

　　　　outWs.Name = ws2.Cells(i, 1).Value

　　　　outWb.SaveAs outPath & "\" & ws2.Cells(i, 1).Value & ".xlsx"

　　Next

　　outWb.Close SaveChanges:=False

　　DividBook = outCnt

End Function

サイト内関連ページ

38本目：1シートを複数シートに振り分け

・出題・頂いた回答・解説・補足・サイト内関連ページ

40本目：複数ブックの統合

・出題・頂いた回答・解説・補足・サイト内関連ページ

同じテーマ「VBA100本ノック」の記事

90本目：セルに重なっている画像の削除
 91本目：時間計算（残業時間の月間合計）
92本目：セルの色を16進で返す関数
93本目：複数ブックを連結して再分割
94本目：表範囲からHTMLのtableタグを作成
 95本目：図形のテキストを検索するフォーム作成
 96本目：Accessデータを取得（マスタ結合&抽出）
97本目：Accessデータを取得（グループ集計）
98本目：席替えルールが守られているか確認
 99本目：自動席替え（行列と前後左右が全て違うように）
100本目：WEBから100本ノックのリストを取得

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
93本目：複数ブックを連結して再分割

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.

VBA練習問題
VBA100本ノック 93本目：複数ブックを連結して再分割