VBA 条件別に他のブックに転記

初めに

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

お題の内容

1. 売上実績.xlsmから各営業所ごとにデータを転記する
2. 売上は一年分を合計したものを転記する

ファイル階層

C:.
│  
│  売上情報.xlsm
│  
└─営業所
        大阪.xlsx
        広島.xlsx
        札幌.xlsx
        東京.xlsx
        横浜.xlsx
        福岡.xlsx
        鹿児島.xlsx
        

コードと実行結果

md_01_集計

'**************************宣言セクション***********************
Option Explicit
Option Base 1
'処理時間記録用変数(別モジュール（リセット）でも使用する)
Public startTime As Double
Public endTime As Double
Public processTime As Double
'全データを格納する配列を宣言
Dim Arr() As Variant
'**************************************************************

Sub 実行()
Application.ScreenUpdating = False

Call タイマー開始
Call ベースの配列作成(Arr)
Call 配列整形と各営業所へ転記(Arr)
Call タイマー終了(startTime, endTime, processTime)

Application.ScreenUpdating = True
End Sub

Sub ベースの配列作成(ByRef InArr() As Variant)

'最終行と最終列用
Dim LastRow As Long: LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long: LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'配列（要素全部を格納する用）
ReDim InArr(LastRow - 1, LastCol)
'配列に格納
InArr() = Range(Cells(2, 1), Cells(LastRow, LastCol)).Value

End Sub

Sub 配列整形と各営業所へ転記(ByRef InArr() As Variant)

'ファイルパスを格納、ファイル名は拡張子がxlsxのものをすべてを処理対象とする
Dim FilePath As String: FilePath = ThisWorkbook.Path & "\" & "営業所" & "\"
Dim File As String: File = Dir(FilePath & "*.xlsx")
'所属支店振り分け用のキー
Dim key As String
'配列用
Dim ListArr()  As Variant   '一次元配列（処理する配列の番号を格納する用）
Dim SortArr() As Variant   '二次元配列（所属支店別にソートした配列を格納する用）
'カウント用
Dim i As Long, j As Long, k As Long
Dim n As Long
'集計用
Dim Total As Long: Total = 0
'処理するBookとSheet用
Dim wb As Workbook
Dim ws As Worksheet
'Dir関数がファイル名を返さなくなるまで繰り返す
Do While File <> ""
    Workbooks.Open FilePath & File
    '開いたBookと処理するシートを格納
    Set wb = ActiveWorkbook
    Set ws = wb.Sheets("Sheet1")
    '開いたブックの拡張子以前の文字列を切り出して、変数に格納
    key = Left(File, InStrRev(File, ".") - 1)
    'カウントアップ用の変数をリセット
    n = 0
    '配列の1次元目の数だけ
    For i = LBound(InArr, 1) To UBound(InArr, 1)
        '開いたブック名と比較して同じなら
        If InArr(i, 3) = key Then
            'カウントアップ
            n = n + 1
            '動的配列を値を保持したまま一つ増やす
            ReDim Preserve ListArr(n)
            '何番目の配列でヒットしたのかを記録していく
            ListArr(n) = i
        End If
    Next
    '同じファイル名でヒットした配列の数がわかったら所属部署別に値を格納していく動的配列を初期化
    ReDim SortArr(UBound(ListArr), UBound(InArr, 2))
    'SortArrにヒットした配列を代入していく
    For i = LBound(ListArr) To UBound(ListArr)
        For j = LBound(InArr, 2) To UBound(InArr, 2)
            SortArr(i, j) = InArr(ListArr(i), j)
        Next
    Next
    'SortArrの数だけ繰り返し
    For i = LBound(SortArr) To UBound(SortArr)
        '4項目（所属支店はスキップ）の転記と集計の転記
        For j = 1 To 4
            '1と2は普通に転記
            Select Case j
                Case 1, 2
                    Cells(i + 1, j) = SortArr(i, j)
                '３行目はSortArrの２次元目を１つ飛ばして（所属支店を省いて）転記
                Case 3
                    Cells(i + 1, j) = SortArr(i, j + 1)
                '売上5列目から16列目まで足し上げていく
                Case 4
                    For k = 5 To 16
                        Total = Total + SortArr(i, k)
                    Next
                    '合計を転記
                    Cells(i + 1, j) = Total
                    '合計をリセット
                    Total = 0
            End Select
        Next
    Next
    '配列初期化
    Erase ListArr
    Erase SortArr
    '罫線を引く
    Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    '保存して閉じる
    wb.Close SaveChanges:=True
    '次のファイルを格納
    File = Dir
Loop

End Sub

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

Sub タイマー終了(startTime As Double, endTime As Double, processTime As Double)
'タイマー終了、差し引きを取得
endTime = Timer
processTime = endTime - startTime
'完了メッセージと、処理時間を出力
MsgBox "完了しました。" & vbCrLf & "処理時間：" & Round(processTime, 2) & "秒"
End Sub

md_02_クリア

Option Explicit
Sub フォルダ内一括クリア()
Application.ScreenUpdating = False

Call タイマー開始

Dim FilePath As String
FilePath = ThisWorkbook.Path & "\" & "営業所"

'FileSystemObjectを使用し、フォルダ内を操作する
Dim FileSystemObj As Object: Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
Dim obj As Object

'getFolderメソッドでフォルダを取得し、その中のファイルを処理する
For Each obj In FileSystemObj.getfolder(FilePath).Files
    'ファイルをひとつづつ開いていき、見出し以外をクリアする
    Workbooks.Open (FilePath & "\" & obj.Name)
    Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    '保存して閉じる
    ActiveWorkbook.Close SaveChanges:=True
Next
'オブジェクトの開放
Set FileSystemObj = Nothing
Call タイマー終了(startTime, endTime, processTime)

Application.ScreenUpdating = True
End Sub

実行の様子

解説

1 元データを配列に格納する

Sub ベースの配列作成(ByRef InArr() As Variant)

'最終行と最終列用
Dim LastRow As Long: LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long: LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'配列（要素全部を格納する用）
ReDim InArr(LastRow - 1, LastCol)
'配列に格納
InArr() = Range(Cells(2, 1), Cells(LastRow, LastCol)).Value

End Sub

配列Arr()を宣言セクションで宣言し、スコープを広げています。
Arr()を各プロシージャにByRefで渡して使用します。渡されたArr()はInArr()として使用します。
売上情報.xlsmの見出しを除いて、最終行、最終列までを配列に格納します。

2　営業所フォルダのファイルの数だけ繰り返し配列を整形し、転記する(ファイルの数だけ繰り返し)

Do While File <> ""
    Workbooks.Open FilePath & File
    '開いたBookと処理するシートを格納
    Set wb = ActiveWorkbook
    Set ws = wb.Sheets("Sheet1")
    '開いたブックの拡張子以前の文字列を切り出して、変数に格納
    key = Left(File, InStrRev(File, ".") - 1)
    'カウントアップ用の変数をリセット
    n = 0
    '配列の1次元目の数だけ
    For i = LBound(InArr, 1) To UBound(InArr, 1)
        '開いたブック名と比較して同じなら
        If InArr(i, 3) = key Then
            'カウントアップ
            n = n + 1
            '動的配列を値を保持したまま一つ増やす
            ReDim Preserve ListArr(n)
            '何番目の配列でヒットしたのかを記録していく
            ListArr(n) = i
        End If
    Next
    '同じファイル名でヒットした配列の数がわかったら所属部署別に値を格納していく動的配列を初期化
    ReDim SortArr(UBound(ListArr), UBound(InArr, 2))
    'SortArrにヒットした配列を代入していく
    For i = LBound(ListArr) To UBound(ListArr)
        For j = LBound(InArr, 2) To UBound(InArr, 2)
            SortArr(i, j) = InArr(ListArr(i), j)
        Next
    Next
    'SortArrの数だけ繰り返し
    For i = LBound(SortArr) To UBound(SortArr)
        '4項目（所属支店はスキップ）の転記と集計の転記
        For j = 1 To 4
            '1と2は普通に転記
            Select Case j
                Case 1, 2
                    Cells(i + 1, j) = SortArr(i, j)
                '３行目はSortArrの２次元目を１つ飛ばして（所属支店を省いて）転記
                Case 3
                    Cells(i + 1, j) = SortArr(i, j + 1)
                '売上5列目から16列目まで足し上げていく
                Case 4
                    For k = 5 To 16
                        Total = Total + SortArr(i, k)
                    Next
                    '合計を転記
                    Cells(i + 1, j) = Total
                    '合計をリセット
                    Total = 0
            End Select
        Next
    Next
    '配列初期化
    Erase ListArr
    Erase SortArr
    '罫線を引く
    Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    '保存して閉じる
    wb.Close SaveChanges:=True
    '次のファイルを格納
    File = Dir
Loop

処理の流れ

営業所内のファイルを開く
　　　↓
開いたファイルの名前（拡張子を除く）をkeyに格納
　　　↓
所属支店がファイル名と同じか確認する
同じだったら該当の配列のインデックス番号を１次元配列に格納する(ListArr)
　　　↓
新たな配列SortArrへListArrで格納したインデックス番号の配列を代入していく
　　　↓
開いたファイル名（key）の情報の配列SortArrができたら、転記する
　　　↓
４列目はTotalという変数に１か月ごとの売り上げを足し上げたものを転記する
　　　↓
Totalを0で初期化
　　　↓
SortArrの転記が終わったら、ListArrとSortArrを初期化する
　　　↓
保存して閉じる、次のファイルを開く（以下すべてファイル分繰り返し）

3 リセットについて

'FileSystemObjectを使用し、フォルダ内を操作する
Dim FileSystemObj As Object: Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
Dim obj As Object

'getFolderメソッドでフォルダを取得し、その中のファイルを処理する
For Each obj In FileSystemObj.getfolder(FilePath).Files
    'ファイルをひとつづつ開いていき、見出し以外をクリアする
    Workbooks.Open (FilePath & "\" & obj.Name)
    Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    '保存して閉じる
    ActiveWorkbook.Close SaveChanges:=True
Next

FileSystemObjectを使用してみました！（初めて）
Dir()を使った処理とあまり変わらない気がしましたので好みの問題かなと思いました！
ですが、便利さで言ったらFileSystemObjectの方に軍配が上がりそうな気がしますね。
こちらに関しては今後も使用して慣れていきたいです。
CreateObjectメソッドに指定する引数は、"Scripting.FileSystemObject"ですが、こちらは入力補完されないので注意した方がよいかと思います。

終わりに

勉強会の内容も難しくなってきました！
常にギリギリでついて行っているので勉強を続けて、置いていかれないようにしたいです！