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

VBAを100本の練習問題で鍛えます
最終更新日: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シートを複数シートに振り分け
1シートを複数シートに振り分ける問題です。「土日祝」と「平日」でシートを分けます。ツイッター連動企画です。ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。VBAテスト用のサンプルデータは、VBA100本ノックの目次ページからもダウンロードできます。
40本目:複数ブックの統合
指定フォルダ内のExcelブックから指定シートを集めてくる問題です。ツイッター連動企画です。ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。VBAテスト用のサンプルデータはご自身でご用意ください。




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

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


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

エクセル馬名ダービー|エクセル雑感(2021-07-21)
在庫を減らせ!毎日棚卸ししろ!|エクセル雑感(2021-07-05)
日付型と通貨型のValueとValue2について|エクセル雑感(2021-06-26)
DXってなんだ? ITと何が違うの?|エクセル雑感(2021-06-24)
エクセルVBA 段級位 目安|エクセル雑感(2021-06-21)
ローカル版エクセルが「Office Scripts」に変わる日|エクセル雑感(2021-06-10)
新関数SORTBYをVBAで利用するラップ関数を作成|VBA技術解説(2021-06-12)
VBA今日のひとこと/VBA今日の教訓 on Twitter|エクセル雑感(2021-06-10)
VBAの演算子まとめ(演算子の優先順位)|VBA技術解説(2021-06-09)
画像が行列削除についてこない場合の対処|VBA技術解説(2021-06-04)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.Excelショートカットキー一覧|Excelリファレンス
3.変数宣言のDimとデータ型|VBA入門
4.RangeとCellsの使い方|VBA入門
5.繰り返し処理(For Next)|VBA入門
6.マクロって何?VBAって何?|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
9.セルに文字を入れるとは(Range,Value)|VBA入門
10.とにかく書いてみよう(Sub,End Sub)|VBA入門




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


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



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