VBA100本ノック 93本目:複数ブックを連結して再分割
「月別」フォルダの年月別のファイルを集め、「支店別」フォルダに支店ファイルで出力する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
「月別」フォルダには同一フォーマット(1シートのみ)の年月別のファイルがあります。
全データを集め、支店別に分割し直し「支店別」フォルダに「支店CD.xlsx」で出力してください。
フォーマットは画像及びサンプルファイルにて。
※「月別」「支店別」フォルダのパスは任意
https://excel-ubara.com/vba100sample/VBA100_93.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
基本的な流れは同じですが、
FSOに変更したりステータスバーへの進捗表示や件数表示を加えたりしました。
VBA記述はWithを多用した書き方にしてみました。ご参考まで。
補足
特に説明するような部分も無いと思います。
別プロセスで処理してはいても、見えているのは起動した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
サイト内関連ページ
同じテーマ「VBA100本ノック」の記事
90本目:セルに重なっている画像の削除
91本目:時間計算(残業時間の月間合計)
92本目:セルの色を16進で返す関数
93本目:複数ブックを連結して再分割
94本目:表範囲からHTMLのtableタグを作成
95本目:図形のテキストを検索するフォーム作成
96本目:Accessデータを取得(マスタ結合&抽出)
97本目:Accessデータを取得(グループ集計)
98本目:席替えルールが守られているか確認
99本目:自動席替え(行列と前後左右が全て違うように)
100本目:WEBから100本ノックのリストを取得
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(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)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.条件分岐(Select Case)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 93本目:複数ブックを連結して再分割
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。