初めに

VBA勉強会にてお題に沿ってVBAを書いたものになります。
私自身VBA歴はまだまだ浅く、勉強中の身ですのでベストプラクティスとは言えないコードになっていることと思います。そのためあまり参考にならない可能性がありますのでご了承ください。

お題

各支社から毎月社員の売上データが報告されます。
今回は各支社その年度での売上情報を1つのファイルに集約してください。
集約項目は社員番号、氏名、所属支店、性別、各月の売上金額です。

ファイルの内容

ファイル階層

C:.
│ 
│  売上情報.xlsm
│  
└─営業所
    ├─10月
    │      大阪10月.xlsx
    │      広島10月.xlsx
    │      札幌10月.xlsx
    │      東京10月.xlsx
    │      横浜10月.xlsx
    │      福岡10月.xlsx
    │      鹿児島10月.xlsx
    │      
    ├─11月
    │      大阪11月.xlsx
    │      広島11月.xlsx
    │      札幌11月.xlsx
    │      東京11月.xlsx
    │      横浜11月.xlsx
    │      福岡11月.xlsx
    │      鹿児島11月.xlsx
    │      
    ├─12月
    │      大阪12月.xlsx
    │      広島12月.xlsx
    │      札幌12月.xlsx
    │      東京12月.xlsx
    │      横浜12月.xlsx
    │      福岡12月.xlsx
    │      鹿児島12月.xlsx
    │      
    ├─1月
    │      大阪1月.xlsx
    │      広島1月.xlsx
    │      札幌1月.xlsx
    │      東京1月.xlsx
    │      横浜1月.xlsx
    │      福岡1月.xlsx
    │      鹿児島1月.xlsx
    │      
    ├─2月
    │      大阪2月.xlsx
    │      広島2月.xlsx
    │      札幌2月.xlsx
    │      東京2月.xlsx
    │      横浜2月.xlsx
    │      福岡2月.xlsx
    │      鹿児島2月.xlsx
    │      
    ├─3月
    │      大阪3月.xlsx
    │      広島3月.xlsx
    │      札幌3月.xlsx
    │      東京3月.xlsx
    │      横浜3月.xlsx
    │      福岡3月.xlsx
    │      鹿児島3月.xlsx
    │      
    ├─4月
    │      大阪4月.xlsx
    │      広島4月.xlsx
    │      札幌4月.xlsx
    │      東京4月.xlsx
    │      横浜4月.xlsx
    │      福岡4月.xlsx
    │      鹿児島4月.xlsx
    │      
    ├─5月
    │      大阪5月.xlsx
    │      広島5月.xlsx
    │      札幌5月.xlsx
    │      東京5月.xlsx
    │      横浜5月.xlsx
    │      福岡5月.xlsx
    │      鹿児島5月.xlsx
    │      
    ├─6月
    │      大阪6月.xlsx
    │      広島6月.xlsx
    │      札幌6月.xlsx
    │      東京6月.xlsx
    │      横浜6月.xlsx
    │      福岡6月.xlsx
    │      鹿児島6月.xlsx
    │      
    ├─7月
    │      大阪7月.xlsx
    │      広島7月.xlsx
    │      札幌7月.xlsx
    │      東京7月.xlsx
    │      横浜7月.xlsx
    │      福岡7月.xlsx
    │      鹿児島7月.xlsx
    │      
    ├─8月
    │      大阪8月.xlsx
    │      広島8月.xlsx
    │      札幌8月.xlsx
    │      東京8月.xlsx
    │      横浜8月.xlsx
    │      福岡8月.xlsx
    │      鹿児島8月.xlsx
    │      
    └─9月
            大阪9月.xlsx
            広島9月.xlsx
            札幌9月.xlsx
            東京9月.xlsx
            横浜9月.xlsx
            福岡9月.xlsx
            鹿児島9月.xlsx

売上情報.xlsm

Sheet1　→ 集計先になるシートです
収集データ　→　収集してきたデータを一時的に保持するシートです
横浜1月.xlsx　→　各月のフォルダにこのような形式の各営業所のファイルが存在しています

全コード

md_01_実行

Option Explicit
Option Base 1
Dim DirName As String
Dim Arr As Variant
Dim startTime As Double
Dim endTime As Double
Dim processTime As Double
Sub 実行()
Application.ScreenUpdating = False

Dim rslt As VbMsgBoxResult
Dim fd As FileDialog
Dim FolderPath As String

'ダイアログで選択したフォルダを取得
'msoFileDialogFilePicker ユーザーがファイルを選択
'msoFileDialogFolderPicker ユーザーがフォルダーを選択
Set fd = Application.FileDialog(msoFileDialogFolderPicker)

If (fd.Show = True) Then
    FolderPath = fd.SelectedItems.Item(1)
Else
    MsgBox "キャンセルしました"
    End
End If

'データを集約していく配列
ReDim Arr(1, 6)
Arr(1, 1) = "社員番号"
Arr(1, 2) = "氏名"
Arr(1, 3) = "所属支店"
Arr(1, 4) = "性別"
Arr(1, 5) = "売上"
Arr(1, 6) = "月"

Call タイマー開始
'ダイアログで選択したフォルダパスを渡して実行開始
Call データ取得(FolderPath, Arr)
'集めたデータを収集データシートに一括代入する
Sheets("収集データ").Select
Sheets("収集データ").Range(Cells(1, 1), Cells(UBound(Arr, 1), UBound(Arr, 2))) = Arr
Call タイマー終了(startTime, endTime, processTime)
rslt = MsgBox("処理時間：" & Round(processTime, 2) & "秒" & vbCrLf & "データ収集が完了しました。続けて転記処理を行いますか？", Buttons:=vbYesNo)

'続けて処理する場合、Arrを開放する（単独で転記処理ができるように別の配列を定義するため）
If rslt = vbYes Then
    Erase Arr
    Call 転記
Else
    MsgBox ("処理を終了します")
End If

Application.ScreenUpdating = True
End Sub

Sub データ取得(ByVal WKDirPath As String, ByRef InArr)

'FileSystemObjectを使用し、フォルダ内を操作する
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim DirObj As Object
Dim FileObj As Object
Dim TmpArr() As Variant
Dim LastRow As Long
Dim LastCol As Long

'getFolderメソッドでsubfoldersを指定し、すべてのフォルダ名を取得する
For Each DirObj In FSO.getfolder(WKDirPath).subfolders
    'サブフォルダのファイル名まで取得したいため再帰呼び出し実行
    '再帰呼び出しを実行するとDirObjにアクセスできなくなるの。親フォルダ名を保持したいのでここで変数に格納しておく
    DirName = DirObj.Name
     '営業所フォルダから取得したサブフォルダのパスを「Sub 再度データ取得（）」に渡す。
    Call データ取得(DirObj.Path, InArr)
Next

'サブフォルダ内のすべてのファイルの処理を実行する
For Each FileObj In FSO.getfolder(WKDirPath).Files

    Workbooks.Open (WKDirPath & "\" & FileObj.Name)
    
    '最終行と最終列を取得(最終列月を取得するため一つ多めにとる)
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
    '集計時にどのフォルダから取得したか判別するためにフォルダ名の項目をセルに転記
    Range(Cells(2, LastCol), Cells(LastRow, LastCol)) = DirName
    
    '配列を初期化し、開いたファイルから取得したデータを格納
    ReDim TmpArr(LastRow - 1, LastCol)
    TmpArr() = Range(Cells(2, 1), Cells(LastRow, LastCol)).Value
    
    '開いたファイルから取得したデータArrにマージする
    InArr = Call_MergeArray_Row(InArr, TmpArr)
    
    '保存せずに閉じる
    ActiveWorkbook.Close False
Next

End Sub
'■2個の二次元配列を行方向(縦方向)に結合(マージ)する
Public Function Call_MergeArray_Row(arr1 As Variant, arr2 As Variant) As Variant
     
    '■結合(マージ)後の配列サイズ
    '■■行方向(縦)に結合、列方向(横)は二次元配列の大きい方に合わせる。
    Dim ROW_NEW As Long
    Dim COL_NEW As Long
    '１次元目数を足してROW_NEWに格納
    ROW_NEW = UBound(arr1, 1) + UBound(arr2, 1)
    '2次元目は２つの配列を比較して大きい方の列数とし、COL_NEWに格納
    COL_NEW = Application.WorksheetFunction.Max(UBound(arr1, 2), UBound(arr2, 2))
     
    '■結合(マージ)後の二次元配列
    '実際はマージというより、新たに配列を作り、そこに二つの配列の要素を追加していく
    Dim newArr As Variant
    '２つの配列の合計行数と２つの配列の最大行数で初期化
    ReDim newArr(1 To ROW_NEW, 1 To COL_NEW)
    
    '■二次元配列を結合処理
    Dim i As Long
    Dim j As Long
    'まずは一つ目の配列の値を新しい配列に代入していく
    '新しい配列の一次元目の要素数繰り返し
    For i = 1 To ROW_NEW
        'もし、iが一つ目の配列の要素数に到達していないなら
        If i <= UBound(arr1, 1) Then
            '一つ目の配列の要素を新しい配列に代入する
            For j = 1 To COL_NEW
                '代入する際に一つ目の配列の2次元目の要素数が、jを超えていなかったら
                If j <= UBound(arr1, 2) Then
                    '普通に代入していく
                    newArr(i, j) = arr1(i, j)
                '超えていたら
                Else
                    '何も入れるデータがないのでEmptyを代入する
                    newArr(i, j) = Empty
                End If
            Next j
        'iが、一つ目の配列の1次元目の要素数に並んだら、一つ目の配列の代入が終わっているので
        Else
            '2つ目の配列の要素を代入する処理へシフト
            For j = 1 To COL_NEW
                If j <= UBound(arr2, 2) Then
                    newArr(i, j) = arr2(i - UBound(arr1, 1), j)
                Else
                    newArr(i, j) = Empty
                End If
            Next j
        End If
    Next i
     
     '新しくできた配列を返す。返すとそれをArrを参照しているInArrに代入するのでArrにマージできたことと同じになる
    Call_MergeArray_Row = newArr
     
End Function

Sub タイマー開始()
'タイマー開始
startTime = Timer
End Sub

Sub タイマー終了(startTime As Double, endTime As Double, processTime As Double)
'タイマー終了、差し引きを取得
endTime = Timer
processTime = endTime - startTime
End Sub

md_02_転記

Option Explicit

Sub 転記()

If Sheets("収集データ").Range("A1") = "" Then
    MsgBox "転記データがありません"
    End
End If

Dim i As Long, j As Long
Dim DataArr As Variant
Dim ListArr As Variant
Dim LastRow As Long: LastRow = Sheets("収集データ").Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long: LastCol = Sheets("収集データ").Cells(1, Columns.Count).End(xlToLeft).Column

Dim 社員番号 As String, 売上 As String, 月 As String
Dim Rng As Range

Sheets("収集データ").Select
'収集データを配列に格納
DataArr = Sheets("収集データ").Range(Cells(2, 1), Cells(LastRow, LastCol)).Value

Sheet1.Select
'一意のデータベースを作成する
For i = 2 To LastRow
    For j = 1 To 4
        Sheet1.Cells(i, j) = DataArr(i - 1, j)
    Next
Next
'重複削除
Range("A1").CurrentRegion.RemoveDuplicates (Array(1, 2, 3, 4))

'DataArrの数だけ転記処理
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
    '情報を変数に格納（可読性向上）
    社員番号 = DataArr(i, 1)
    売上 = DataArr(i, 5)
    月 = DataArr(i, 6)
    
    '月ごとに転記
    Select Case 月
        Case "4月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 4).Value = 売上
        Case "5月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 5).Value = 売上
        Case "6月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 6).Value = 売上
        Case "7月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 7).Value = 売上
        Case "8月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 8).Value = 売上
        Case "9月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 9).Value = 売上
        Case "10月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 10).Value = 売上
        Case "11月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 11).Value = 売上
        Case "12月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 12).Value = 売上
        Case "1月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 13).Value = 売上
        Case "2月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 14).Value = 売上
        Case "3月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 15).Value = 売上
    End Select
Next

MsgBox "転記が完了しました"

End Sub

md_03_クリア

Option Explicit

Sub クリア()
Application.DisplayAlerts = False

Dim ws As Variant
Dim b As Boolean

Sheets("収集データ").Cells.ClearContents
Sheet1.Range("A1").CurrentRegion.Offset(1, 0).ClearContents

'ピボットテーブルのシートが存在するかチェック
b = ExistsSheet("ピボットテーブル")

'存在していたら削除
If b = True Then Sheets("ピボットテーブル").Delete

Application.DisplayAlerts = True

End Sub
' Sheets に指定した名前のシートが存在するか判定する
Public Function ExistsSheet(ByVal bookName As String)

Dim ws As Worksheet

'ワークシートオブジェクトの集合体からひとつづつ抜き出してwsに入れて実行している
For Each ws In Worksheets
    'シート名が引数で渡された文字列と同じだったら
    If ws.Name = bookName Then
        '存在する
        ExistsSheet = True
        '見つけたら抜ける
        Exit Function
    End If
Next

' 存在しない
ExistsSheet = False
End Function

md_04_Pivot作成

Option Explicit

Sub Pivot作成()

If Sheets("収集データ").Range("A1") = "" Then
    MsgBox "転記データがありません"
    End
End If

' ピボットテーブル用のシート追加
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "ピボットテーブル"
' ピボットキャッシュ作成 → ピボットテーブル作成
ThisWorkbook.PivotCaches.Create(xlDatabase, Worksheets("収集データ").Range("A1").CurrentRegion).CreatePivotTable Sheets("ピボットテーブル").Range("A3"), "ピボット1"
    
With ActiveSheet.PivotTables("ピボット1")
    'フィールドを設定
    .PivotFields("社員番号").Orientation = xlRowField
    .PivotFields("月").Orientation = xlColumnField
    .PivotFields("売上").Orientation = xlDataField
    '書式設定（カンマつける）
    .DataBodyRange.NumberFormat = "#,#"
End With
     
End Sub

データ取得～転記

転記せずにピポットテーブルを作成

転記せずに一度取得データを確認してから、転記処理
（※画面更新ONしてます）

説明

まず、データの取得、転記、ピポットテーブルの作成、クリアを単独処理できるようにモジュールを切り分けました。転記、ピポットテーブルは、収集データから再度値を取得するようにしています。その意味も込めて収集データというシートを作成しています。（もともとの課題では存在していなかった。）単に連続処理してもよかったですが、自分が使うならこうしたいなと思ったので。

選択したフォルダのサブフォルダまで取得する処理

Dim fd As FileDialog
Dim FolderPath As String

'ダイアログで選択したフォルダを取得
'msoFileDialogFilePicker ユーザーがファイルを選択
'msoFileDialogFolderPicker ユーザーがフォルダーを選択
Set fd = Application.FileDialog(msoFileDialogFolderPicker)

If (fd.Show = True) Then
    FolderPath = fd.SelectedItems.Item(1)
Else
    MsgBox "キャンセルしました"
    End
End If

Application.FileDialog(msoFileDialogFolderPicker)でダイアログ選択画面を表示します。その際、取得したいのがファイルなのかフォルダなのかで引数を選択します。
今回はフォルダを取得したいのでmsoFileDialogFolderPickerにしました。
Itemsプロパティの説明は下記の通りで、

指定したオブジェクトに関連付けられたテキストを取得します。
値の取得のみ可能です。

今回はこれでフォルダのパスが取得できています。

データの取得

次に取得したフォルダパスをデータ取得に渡して実行します。

Call データ取得(FolderPath, Arr)

Sub データ取得(ByVal WKDirPath As String, ByRef InArr)

'FileSystemObjectを使用し、フォルダ内を操作する
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim DirObj As Object
Dim FileObj As Object
Dim TmpArr() As Variant
Dim LastRow As Long
Dim LastCol As Long

'getFolderメソッドでsubfoldersを指定し、すべてのフォルダ名を取得する
For Each DirObj In FSO.getfolder(WKDirPath).subfolders
    'サブフォルダのファイル名まで取得したいため再帰呼び出し実行
    '再帰呼び出しを実行するとDirObjにアクセスできなくなるの。親フォルダ名を保持したいのでここで変数に格納しておく
    DirName = DirObj.Name
     '営業所フォルダから取得したサブフォルダのパスを「Sub 再度データ取得（）」に渡す。
    Call データ取得(DirObj.Path, InArr)
    
Next

'サブフォルダ内のすべてのファイルの処理を実行する
For Each FileObj In FSO.getfolder(WKDirPath).Files

    Workbooks.Open (WKDirPath & "\" & FileObj.Name)
    
    '最終行と最終列を取得(最終列月を取得するため一つ多めにとる)
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
    '集計時にどのフォルダから取得したか判別するためにフォルダ名の項目をセルに転記
    Range(Cells(2, LastCol), Cells(LastRow, LastCol)) = DirName
    
    '配列を初期化し、開いたファイルから取得したデータを格納
    ReDim TmpArr(LastRow - 1, LastCol)
    TmpArr() = Range(Cells(2, 1), Cells(LastRow, LastCol)).Value
    
    '開いたファイルから取得したデータArrにマージする
    InArr = Call_MergeArray_Row(InArr, TmpArr)
    
    '保存せずに閉じる
    ActiveWorkbook.Close False
Next

End Sub

FileSystemObjを使用しました。
ForEach文で渡されたフォルダパスを使用し、.subfoldersでサブフォルダを取得しています。（1月～12月というフォルダを取得）
サブフォルダがわかったら、さらにもう一度自分を呼び出しています。（再帰呼び出し）

Call データ取得(DirObj.Path, InArr)

これで、取得したサブフォルダ（1月～12月）のパスを渡して、大阪や広島などの支店別ファイルを繰り返し繰り返し開いて、データを配列に足し上げていく処理を行っています。まずは処理の流れを出力してみますね。

debug.print差し込み箇所

debug.printを差し込みました！

Sub データ取得(ByVal WKDirPath As String, ByRef InArr)

'FileSystemObjectを使用し、フォルダ内を操作する
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim DirObj As Object
Dim FileObj As Object
Dim TmpArr() As Variant
Dim LastRow As Long
Dim LastCol As Long

Debug.Print "フルパス" & WKDirPath & "を取得しました"
'getFolderメソッドでsubfoldersを指定し、すべてのフォルダ名を取得する
For Each DirObj In FSO.getfolder(WKDirPath).subfolders
    'サブフォルダのファイル名まで取得したいため再帰呼び出し実行
    '再帰呼び出しを実行するとDirObjにアクセスできなくなるの。親フォルダ名を保持したいのでここで変数に格納しておく
    DirName = DirObj.Name
    Debug.Print "フォルダ名" & DirName & "を取得しました"
     '営業所フォルダから取得したサブフォルダのパスを「Sub 再度データ取得（）」に渡す。
    Call データ取得(DirObj.Path, InArr)
Next

'サブフォルダ内のすべてのファイルの処理を実行する
For Each FileObj In FSO.getfolder(WKDirPath).Files

    Workbooks.Open (WKDirPath & "\" & FileObj.Name)
    Debug.Print FileObj & "の処理を実行"
    '最終行と最終列を取得(最終列月を取得するため一つ多めにとる)
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
    '集計時にどのフォルダから取得したか判別するためにフォルダ名の項目をセルに転記
    Range(Cells(2, LastCol), Cells(LastRow, LastCol)) = DirName
    
    '配列を初期化し、開いたファイルから取得したデータを格納
    ReDim TmpArr(LastRow - 1, LastCol)
    TmpArr() = Range(Cells(2, 1), Cells(LastRow, LastCol)).Value
    
    '開いたファイルから取得したデータArrにマージする
    InArr = Call_MergeArray_Row(InArr, TmpArr)
    
    '保存せずに閉じる
    ActiveWorkbook.Close False
Next

End Sub

出力結果

イミディエイトウインドウ

フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所を取得しました
フォルダ名10月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\大阪10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\広島10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\札幌10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\東京10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\横浜10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\福岡10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\10月\鹿児島10月.xlsxの処理を実行
フォルダ名11月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\大阪11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\広島11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\札幌11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\東京11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\横浜11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\福岡11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\11月\鹿児島11月.xlsxの処理を実行
フォルダ名12月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\大阪12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\広島12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\札幌12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\東京12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\横浜12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\福岡12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\12月\鹿児島12月.xlsxの処理を実行
フォルダ名1月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\大阪1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\広島1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\札幌1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\東京1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\横浜1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\福岡1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\1月\鹿児島1月.xlsxの処理を実行
フォルダ名2月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\大阪2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\広島2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\札幌2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\東京2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\横浜2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\福岡2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2月\鹿児島2月.xlsxの処理を実行
フォルダ名3月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\大阪3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\広島3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\札幌3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\東京3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\横浜3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\福岡3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\3月\鹿児島3月.xlsxの処理を実行
フォルダ名4月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\大阪4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\広島4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\札幌4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\東京4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\横浜4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\福岡4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\4月\鹿児島4月.xlsxの処理を実行
フォルダ名5月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\大阪5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\広島5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\札幌5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\東京5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\横浜5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\福岡5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\5月\鹿児島5月.xlsxの処理を実行
フォルダ名6月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\大阪6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\広島6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\札幌6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\東京6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\横浜6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\福岡6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\6月\鹿児島6月.xlsxの処理を実行
フォルダ名7月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\大阪7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\広島7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\札幌7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\東京7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\横浜7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\福岡7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\7月\鹿児島7月.xlsxの処理を実行
フォルダ名8月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\大阪8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\広島8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\札幌8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\東京8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\横浜8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\福岡8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\8月\鹿児島8月.xlsxの処理を実行
フォルダ名9月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\大阪9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\広島9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\札幌9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\東京9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\横浜9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\福岡9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\9月\鹿児島9月.xlsxの処理を実行

このような感じで処理が進んでいます！今回のフォルダ階層では月のファイルが12個、その月のフォルダに支店のファイルが7個あるので、合計84個のエクセルファイルを開いては配列に格納して閉じるという処理を行っています。

そして、配列に格納する際、どの月のデータなのか判別できるように開いたフォルダ名を最終列に追加して、のちの処理である月別に転記する処理で利用します。

実行結果としては約16秒程で配列が完成し、集計データシートに転記しています。
今回2次元配列の1次元目（行）を追加していますが、通常2次元目しか追加できないのですが、下記サイトの関数を使用して実現しています！

普段誰かが作った関数を理解できないのでをあまり使ったことがないのですが、どうしても配列を結合させる方法を身につけておきたいと思ったので、コードを一つ一つ読み解いてコメントをつけていったら処理が理解できました。
そのためありがたく利用させていただきました！

'■2個の二次元配列を行方向(縦方向)に結合(マージ)する
Public Function Call_MergeArray_Row(arr1 As Variant, arr2 As Variant) As Variant
     
    '■結合(マージ)後の配列サイズ
    '■■行方向(縦)に結合、列方向(横)は二次元配列の大きい方に合わせる。
    Dim ROW_NEW As Long
    Dim COL_NEW As Long
    '１次元目数を足してROW_NEWに格納
    ROW_NEW = UBound(arr1, 1) + UBound(arr2, 1)
    '2次元目は２つの配列を比較して大きい方の列数とし、COL_NEWに格納
    COL_NEW = Application.WorksheetFunction.Max(UBound(arr1, 2), UBound(arr2, 2))
     
    '■結合(マージ)後の二次元配列
    '実際はマージというより、新たに配列を作り、そこに二つの配列の要素を追加していく
    Dim newArr As Variant
    '２つの配列の合計行数と２つの配列の最大行数で初期化
    ReDim newArr(1 To ROW_NEW, 1 To COL_NEW)
    
    '■二次元配列を結合処理
    Dim i As Long
    Dim j As Long
    'まずは一つ目の配列の値を新しい配列に代入していく
    '新しい配列の一次元目の要素数繰り返し
    For i = 1 To ROW_NEW
        'もし、iが一つ目の配列の要素数に到達していないなら
        If i <= UBound(arr1, 1) Then
            '一つ目の配列の要素を新しい配列に代入する
            For j = 1 To COL_NEW
                '代入する際に一つ目の配列の2次元目の要素数が、jを超えていなかったら
                If j <= UBound(arr1, 2) Then
                    '普通に代入していく
                    newArr(i, j) = arr1(i, j)
                '超えていたら
                Else
                    '何も入れるデータがないのでEmptyを代入する
                    newArr(i, j) = Empty
                End If
            Next j
        'iが、一つ目の配列の1次元目の要素数に並んだら、一つ目の配列の代入が終わっているので
        Else
            '2つ目の配列の要素を代入する処理へシフト
            For j = 1 To COL_NEW
                If j <= UBound(arr2, 2) Then
                    newArr(i, j) = arr2(i - UBound(arr1, 1), j)
                Else
                    newArr(i, j) = Empty
                End If
            Next j
        End If
    Next i
     
     '新しくできた配列を返す。返すとそれをArrを参照しているInArrに代入するのでArrにマージできたことと同じになる
    Call_MergeArray_Row = newArr
     
End Function

転記

まずは、転記する際は、下記のコードで収集データに値が入っているのでそこの値で配列を作成します。連続処理の場合はそのままArrを使用すればよいのですが、処理を切り分けたかったため、ここで再度配列を作成しています。

Sub実行( )

'集めたデータを収集データシートに一括代入する
Sheets("収集データ").Select
Sheets("収集データ").Range(Cells(1, 1), Cells(UBound(Arr, 1), UBound(Arr, 2))) = Arr

転記の処理の説明ですが、

Sub 転記()

If Sheets("収集データ").Range("A1") = "" Then
    MsgBox "転記データがありません"
    End
End If

Dim i As Long, j As Long
Dim DataArr As Variant
Dim ListArr As Variant
Dim LastRow As Long: LastRow = Sheets("収集データ").Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long: LastCol = Sheets("収集データ").Cells(1, Columns.Count).End(xlToLeft).Column

Dim 社員番号 As String, 売上 As String, 月 As String
Dim Rng As Range

Sheets("収集データ").Select
'収集データを配列に格納
DataArr = Sheets("収集データ").Range(Cells(2, 1), Cells(LastRow, LastCol)).Value

Sheet1.Select
'一意のデータベースを作成する
For i = 2 To LastRow
    For j = 1 To 4
        Sheet1.Cells(i, j) = DataArr(i - 1, j)
    Next
Next
'重複削除
Range("A1").CurrentRegion.RemoveDuplicates (Array(1, 2, 3, 4))

'DataArrの数だけ転記処理
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
    '情報を変数に格納（可読性向上）
    社員番号 = DataArr(i, 1)
    売上 = DataArr(i, 5)
    月 = DataArr(i, 6)
    
    '月ごとに転記
    Select Case 月
        Case "4月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 4).Value = 売上
        Case "5月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 5).Value = 売上
        Case "6月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 6).Value = 売上
        Case "7月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 7).Value = 売上
        Case "8月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 8).Value = 売上
        Case "9月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 9).Value = 売上
        Case "10月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 10).Value = 売上
        Case "11月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 11).Value = 売上
        Case "12月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 12).Value = 売上
        Case "1月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 13).Value = 売上
        Case "2月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 14).Value = 売上
        Case "3月"
            Set Rng = Sheet1.Cells.Find(社員番号)
            Rng.Offset(0, 15).Value = 売上
    End Select
Next

MsgBox "転記が完了しました"

End Sub

まずは取得したデータでSheet1に、一意のキーを作成します。
取得したデータの1次元目はすべて、2次元目は4列目まで転記します。
その後社員番号、名前、所属支店、性別で重複削除をしました。
社員番号だけでもよさそうですね(笑)

次にFor文で、取得した配列の要素すべて分を繰り返し処理します。（792項目）

そして、For文に入れ子で、データベースに月別で、どの行に売り上げを入れるのかSwitch文で分岐を作成しました。その際は、Findメソッドを使用し、一意のキーで検索して、月の値により、いくつOffsetさせるかをSwitch文で処理を振り分けています。

処理としてはこれで完了となります。

ピボットテーブルの作成

要件にはない項目でしたが、そもそも月別に転記する際どうやったらうまく記載できるか考えていた際、Switch文より先にピボットテーブルが頭に浮かびました(笑)
でもそれだと課題の要件満たしていないような・・・と思ったのでおまけとして作成しました。

md_04_Pivot作成

Option Explicit

Sub Pivot作成()

If Sheets("収集データ").Range("A1") = "" Then
    MsgBox "転記データがありません"
    End
End If

' ピボットテーブル用のシート追加
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "ピボットテーブル"
' ピボットキャッシュ作成 → ピボットテーブル作成
ThisWorkbook.PivotCaches.Create(xlDatabase, Worksheets("収集データ").Range("A1").CurrentRegion).CreatePivotTable Sheets("ピボットテーブル").Range("A3"), "ピボット1"
    
With ActiveSheet.PivotTables("ピボット1")
    'フィールドを設定
    .PivotFields("社員番号").Orientation = xlRowField
    .PivotFields("月").Orientation = xlColumnField
    .PivotFields("売上").Orientation = xlDataField
    '書式設定（カンマつける）
    .DataBodyRange.NumberFormat = "#,#"
End With
     
End Sub

こっちのがコードも短いし、見せ方の拡張性なども含めて推せるな～と思いました！
今回の課題は転記先のフォーマットが決まっていたので別枠で作成したという感じです！

クリア

一応クリアも解説したいと思います。
ピボットテーブルを作成しているかいないかの存在チェックを入れました。
シートの存在チェックも下記のサイトですべてのシートの処理はどう書くのか調べてシートで理解を深めました。

そして下記のサイトのFunctionを再利用させていいただきました。

md_03_クリア

Option Explicit

Sub クリア()
Application.DisplayAlerts = False

Dim ws As Variant
Dim b As Boolean

Sheets("収集データ").Cells.ClearContents
Sheet1.Range("A1").CurrentRegion.Offset(1, 0).ClearContents

'ピボットテーブルのシートが存在するかチェック
b = ExistsSheet("ピボットテーブル")

'存在していたら削除
If b = True Then Sheets("ピボットテーブル").Delete

Application.DisplayAlerts = True

End Sub
' Sheets に指定した名前のシートが存在するか判定する
Public Function ExistsSheet(ByVal bookName As String)

Dim ws As Worksheet

'ワークシートオブジェクトの集合体からひとつづつ抜き出してwsに入れて実行している
For Each ws In Worksheets
    'シート名が引数で渡された文字列と同じだったら
    If ws.Name = bookName Then
        '存在する
        ExistsSheet = True
        '見つけたら抜ける
        Exit Function
    End If
Next

' 存在しない
ExistsSheet = False
End Function

これで、ピボットテーブルのシートがあってもなくてもエラーが回避できるようになりました。よく使うエラー回避の方法だと思うのでこちらも今後利用していきたいと思いました。

感想

再帰呼び出し処理を初めて利用しました。
F8キーでひとつづつデバッグする際、動きを目で追っていたら上にいったり下に行ったりで面白い動きをしていてすごく興奮しました(笑)なるほどな～と思いながら目が回りそうになるほど繰り返し実行して理解を深めました。どういうときに使うのかまではまだイメージできるほどではないですが、今回はいい経験ができたなと思っています。
あとは、再利用性のあるとてもいいFunctionがネットにたくさんあるので、うまくそういうのをガンガン利用していって効率の良いものを作っていきたいと思いました！また、そういうFunctionを作成できるようになりたいと、目標ができました！
以上

追記

ちょっと気になったことがあったので試してみた結果を共有します！
ファイル階層をいじったらどうなるのか？ということです。
いたずらを仕掛けてみました。

C:.
└─営業所
    ├─2022
    │  ├─１Q
    │  │  ├─4月
    │  │  ├─5月
    │  │  └─6月
    │  ├─２Q
    │  │  ├─7月
    │  │  ├─8月
    │  │  └─9月
    │  ├─３Q
    │  │  ├─10月
    │  │  ├─11月
    │  │  └─12月
    │  └─４Q
    │      ├─1月
    │      ├─2月
    │      └─3月
    └─2023

空の2023年というフォルダを追加
Q毎に分けたフォルダを追加
その中にそれぞれ月別のフォルダに移動

これで実行したところ、、、
まったく同じ結果を得ることができました！
どんなファイル階層に変更してもコードの修正は一切なしで同じ出力を得ることができました！再帰呼び出しの凄さを思い知りました！

処理の流れ（debug.print出力）

イミディエイトウインドウ

フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所を取得しました
フォルダ名2022を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022を取得しました
フォルダ名１Qを取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Qを取得しました
フォルダ名4月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\大阪4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\広島4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\札幌4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\東京4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\横浜4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\福岡4月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\4月\鹿児島4月.xlsxの処理を実行
フォルダ名5月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\大阪5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\広島5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\札幌5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\東京5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\横浜5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\福岡5月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\5月\鹿児島5月.xlsxの処理を実行
フォルダ名6月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\大阪6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\広島6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\札幌6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\東京6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\横浜6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\福岡6月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\１Q\6月\鹿児島6月.xlsxの処理を実行
フォルダ名２Qを取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Qを取得しました
フォルダ名7月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\大阪7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\広島7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\札幌7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\東京7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\横浜7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\福岡7月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\7月\鹿児島7月.xlsxの処理を実行
フォルダ名8月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\大阪8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\広島8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\札幌8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\東京8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\横浜8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\福岡8月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\8月\鹿児島8月.xlsxの処理を実行
フォルダ名9月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\大阪9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\広島9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\札幌9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\東京9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\横浜9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\福岡9月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\２Q\9月\鹿児島9月.xlsxの処理を実行
フォルダ名３Qを取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Qを取得しました
フォルダ名10月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\大阪10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\広島10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\札幌10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\東京10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\横浜10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\福岡10月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\10月\鹿児島10月.xlsxの処理を実行
フォルダ名11月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\大阪11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\広島11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\札幌11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\東京11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\横浜11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\福岡11月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\11月\鹿児島11月.xlsxの処理を実行
フォルダ名12月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\大阪12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\広島12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\札幌12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\東京12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\横浜12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\福岡12月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\３Q\12月\鹿児島12月.xlsxの処理を実行
フォルダ名４Qを取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Qを取得しました
フォルダ名1月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\大阪1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\広島1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\札幌1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\東京1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\横浜1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\福岡1月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\1月\鹿児島1月.xlsxの処理を実行
フォルダ名2月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\大阪2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\広島2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\札幌2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\東京2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\横浜2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\福岡2月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\2月\鹿児島2月.xlsxの処理を実行
フォルダ名3月を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月を取得しました
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\大阪3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\広島3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\札幌3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\東京3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\横浜3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\福岡3月.xlsxの処理を実行
C:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2022\４Q\3月\鹿児島3月.xlsxの処理を実行
フォルダ名2023を取得しました
フルパスC:\Users\matsu\OneDrive\デスクトップ\VBA勉強会\課題_04\営業所\2023を取得しました

難しい考え方ですがうまく設計すれば、とても都合よく動いてくれるので便利です！
（簡単に書いていますが実装する際は結構試行錯誤して苦労しました^^;）
まだ試したことがない方は一度お試しあれ！

以上