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

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：複数ブックを連結して再分割

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

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック093：複数ブックを連結して再分割
Sub 月別ファイルを結合して支店別に分割し直す()
    
    Dim Path取込フォルダ As String
    Path取込フォルダ = ThisWorkbook.Path & "\月別"
    
    ' ■ フォルダ内の全ファイルの結合
    Dim ws結合シート As Worksheet
    Set ws結合シート = 指定フォルダ内のすべてのブックを結合する(Path取込フォルダ, 1 _
        , ファイル名出力始点セル:=WS実行シート.Range("A2") _
        , 読込結果出力始点セル:=WS実行シート.Range("B2"))
    
    Dim Path出力先フォルダ As String
    Path出力先フォルダ = 連番を付与して新規フォルダを作成する _
        (ThisWorkbook.Path, "支店別" & Format(Date, "yyyymmdd"))
    
    ' ■ 結合ファイルを支店別に再分割
    Call シートを要素ごとにファイル分割する(ws結合シート, 1, 1, Path出力先フォルダ, "支店別")
        
End Sub

汎用関数モジュール

' シートを要素ごとにファイル分割
Function シートを要素ごとにファイル分割する(ws対象シート As Worksheet, 分割対象列 As Long, 見出し行 As Long _
    , Path出力先フォルダ As String, ブック名接頭部 As String) As Worksheet

    ' テンプレートシートを作成
    ws対象シート.Copy
    Dim wsテンプレート As Worksheet
    Set wsテンプレート = ActiveSheet
    wsテンプレート.Name = "wsテンプレート"
    Call 指定行より下をすべて削除する(wsテンプレート, 見出し行 + 1)

    ' 対象シートのコピーを作成
    ws対象シート.Copy
    Dim wsコピー元データ As Worksheet
    Set wsコピー元データ = ActiveSheet
    wsコピー元データ.Name = "wsコピー元データ"
    
    ' コピー元データの見出し行より下の全範囲を取得
    Dim DataRangeコピー元データ As Range
    Set DataRangeコピー元データ = Range(ws対象シート.Range("A1"), ws対象シート.UsedRange)
    Set DataRangeコピー元データ = Intersect(DataRangeコピー元データ _
        , Range(DataRangeコピー元データ.Rows(見出し行 + 1), DataRangeコピー元データ.Rows(DataRangeコピー元データ.Rows.Count)))
    
    ' データエリアを分割対象列でソート
    DataRangeコピー元データ.Sort ws対象シート.Cells(1, 分割対象列)

    ' データエリアを走査
    Dim R_コピー開始行 As Long: R_コピー開始行 = 見出し行 + 1
    Dim R_コピー最終行 As Long
    Dim R As Long
    For R = 見出し行 + 2 To Get最終行(wsコピー元データ)

        ' 対象列の要素が切り替わったタイミングでシートを複製
        If DataRangeコピー元データ.Cells(R, 分割対象列) <> DataRangeコピー元データ.Cells(R + 1, 分割対象列) _
        Or R = Get最終行(wsコピー元データ) Then
            R_コピー最終行 = R
            
            Dim ws分割シート As Worksheet
            wsテンプレート.Copy
            Set ws分割シート = ActiveSheet
            
            Range(wsコピー元データ.Rows(R_コピー開始行), wsコピー元データ.Rows(R_コピー最終行)) _
                .Copy ws分割シート.Cells(見出し行 + 1, 1)
                
            ws分割シート.Parent.SaveAs Path出力先フォルダ & "\" & ブック名接頭部 & "(" & ws対象シート.Cells(R, 分割対象列) & ").xlsx"
            
            ws分割シート.Parent.Close False
            
            R_コピー開始行 = R + 1
            R_コピー最終行 = 0
            
        End If

    Next

    wsコピー元データ.Parent.Close False
    wsテンプレート.Parent.Close False

End Function

' 連番付与付フォルダ作成
Function 連番を付与して新規フォルダを作成する(Path親フォルダ As String, 作成フォルダ名 As String _
    , Optional is第1フォルダにも付番する As Boolean = False) As String
    
    Dim path作成フォルダ As String
    path作成フォルダ = Path親フォルダ & "\" & 作成フォルダ名
    
    ' 作成フォルダ
    If is第1フォルダにも付番する Then
        If Dir(path作成フォルダ, vbDirectory) = "" Then
            MkDir path作成フォルダ
            Exit Function
        End If
    Else
        If Dir(path作成フォルダ & "-1", vbDirectory) = "" Then
            MkDir path作成フォルダ & "-1"
            Exit Function
        End If
    End If
    
    ' まだフォルダがない番号まで連番を進める
    Dim i As Long: i = 2
    Do While Dir(path作成フォルダ & "-" & i, vbDirectory) <> ""
        i = i + 1
    Loop

    ' フォルダを作成
    MkDir path作成フォルダ & "-" & i

    ' 作成したフォルダパスを返す
    連番を付与して新規フォルダを作成する = path作成フォルダ

End Function

' フォルダ内ファイルの結合
Function 指定フォルダ内のすべてのブックを結合する _
    (Path指定フォルダ As String, R_見出し行 As Long _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional ByVal シート名Like条件 As String = "*" _
    , Optional ファイル名出力始点セル As Range, Optional 読込結果出力始点セル As Range) As Worksheet
    
    ' 対象フォルダを取得
    If FSO.FolderExists(Path指定フォルダ) = False Then Exit Function
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder(Path指定フォルダ)
    If 対象フォルダ.Files.Count = 0 Then Exit Function
        
    ' 出力するシートは第1ブックの第1シートを利用
    Dim ws出力シート As Worksheet
    
    ' Like条件テキストを生成
    ファイルLike条件 = ファイルLike条件 & "." & 対象拡張子

    ' ファイルの走査ログを出力する各セルをSet
    Dim ファイル名出力セル As Range: Set ファイル名出力セル = ファイル名出力始点セル
    Dim 読込結果出力セル As Range: Set 読込結果出力セル = 読込結果出力始点セル

    ' 指定フォルダ内のすべてのファイルを走査
    Dim 読取結果テキスト As String
    Dim ファイル As File
    For Each ファイル In 対象フォルダ.Files
        読取結果テキスト = ""
        
        ' 条件を満たすファイルを処理
        If ファイル.Name Like ファイルLike条件 Then
            Call 対象ブック内のすべてのシートを取り込む(ファイル.Path, ws出力シート _
                , R_見出し行, シート名Like条件, 読取結果テキスト)
        Else
            読取結果テキスト = "ファイル名条件に合致せず"
        End If
        
        ' 読取ログの出力
        If Not ファイル名出力セル Is Nothing Then
            ファイル名出力セル.Value = ファイル.Name
            Set ファイル名出力セル = ファイル名出力セル.Offset(1)
        End If
        If Not 読込結果出力セル Is Nothing Then
            読込結果出力セル.Value = 読取結果テキスト
            Set 読込結果出力セル = 読込結果出力セル.Offset(1)
        End If

    Next ' 指定フォルダ内のすべてのファイルを走査
    
    Set 指定フォルダ内のすべてのブックを結合する = ws出力シート

End Function

' ブックごとの取込処理
Private Sub 対象ブック内のすべてのシートを取り込む(ファイルパス As String, ws出力シート As Worksheet _
    , R_見出し行 As Long, シート名Like条件 As String, ByRef 読取結果テキスト As String)

    ' ファイルを開く
    Dim wb読取ブック As Workbook: Set wb読取ブック = Nothing
    On Error Resume Next
    Set wb読取ブック = Workbooks.Open(ファイルパス)
    On Error GoTo 0

    If wb読取ブック Is Nothing Then
        読取結果テキスト = "ブックがエラーで開けませんでした。"
        Exit Sub
    End If
    
    ' 開いたブック内の条件合致シートをループ
    Dim cnt読取シート数 As Long: cnt読取シート数 = 0
    Dim ws読取シート As Worksheet
    For Each ws読取シート In wb読取ブック.Worksheets
        If ws読取シート.Name Like シート名Like条件 Then
    
            ' 最初に読み取ったシートをコピーして出力シートとして使う
            If ws出力シート Is Nothing Then
                ws読取シート.Copy
                Set ws出力シート = ActiveSheet
                cnt読取シート数 = cnt読取シート数 + 1
            
            Else
                
                ' UsedRangeのうち見出し行より下を取得
                Dim コピーエリア As Range
                Set コピーエリア = GetUsedRange指定行以下(ws読取シート, R_見出し行 + 1)
                
                ' コピーを実行
                If Not コピーエリア Is Nothing Then
                    コピーエリア.Copy ws出力シート.Cells(Get最終行(ws出力シート) + 1, コピーエリア.Column)
                    cnt読取シート数 = cnt読取シート数 + 1
                End If
            
            End If
    
        End If
    Next ' 開いたブック内の条件合致シートをループ
        
    読取結果テキスト = cnt読取シート数 & "枚のシートを取込"
    wb読取ブック.Close False
            
End Sub

' UsedRangeから上部を切り取り
Function GetUsedRange指定行以下(対象シート As Worksheet, 指定行 As Long) As Range
    With 対象シート
        Set GetUsedRange指定行以下 = Intersect(.UsedRange, .Rows(指定行).Resize(.UsedRange.Rows.Count))
    End With
End Function

' 最終行の取得
Function Get最終行(指定シート As Worksheet) As Long
    Get最終行 = 指定シート.UsedRange.Rows.Count + 指定シート.UsedRange.Row - 1
End Function

' 指定行より下の削除
Sub 指定行より下をすべて削除する(指定シート As Worksheet, 指定行 As Long)
    With 指定シート
        指定シート.Rows(指定行).Resize(.UsedRange.Rows.Count).Delete
    End With
End Sub