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

VBAを100本の練習問題で鍛えます
公開日：2021-02-22　最終更新日：2021-02-23

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


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


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

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック

マクロ VBA 100本ノック

マクロ VBA 100本ノック

マクロ VBA 100本ノック


サンプルファイルです。
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本ノックのリストを取得


新着記事NEW ・・・新着記事一覧を見る

ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
累計を求める数式あれこれ｜エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE｜エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。｜エクセル雑感(2023-12-28)


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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門



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


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク


↑