40本目：複数ブックの統合

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

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

出題：40本目：複数ブックの統合

#VBA100本ノック 40本目
「data」フォルダ内のExcelファイルについて、シート「2020年12月」のA1からの連続表範囲を集めます。※このシートが無いファイルもある。
自身の既存シート「2020年12月」に集めてください。
1行目は見出しなので2件目からは除く。
※ブック指定と「data」のパス位置は任意

◇ 出題ページはこちら

なお、今回の処理はライブラリが威力を発揮する回で、
汎用関数を1つCallしただけでほぼ完成してしまいました。

それはそれでライブラリづくりの参考にしていただけそうですが、
ある程度しっかり記述したコードも読みたい方もいるかと思います。

よって本ページでは2つの解答を記載しておきますので、
お好きな方をご覧ください。

ソースコード（ライブラリ未使用版）

※ 本問を一発回答する万能型プロシージャを使用していないだけで、
「Get最終行」「指定行より下を削除する」「Isシートが存在」など、
頻出コードを汎用関数化したプロシージャは通常通り使用しています。

メインモジュール

Option Explicit

Private 対象年月 As String
Dim ws出力シート As Worksheet

' 100本ノック040：複数ブックの統合
Sub フォルダ内の対象年月シートを統合する()
    
    ' 対象月の指定
    対象年月 = "2020年12月"
    Set ws出力シート = ThisWorkbook.Worksheets(対象年月)
    
    ' 出力シートをクリア
    Call 指定行より下をすべて削除する(ws出力シート, 2)
    
    ' 対象フォルダを取得
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder("C:\Users\wfsp\Desktop\data")
    
    ' フォルダ内のExcelファイルをループ
    Dim ファイル As File
    For Each ファイル In 対象フォルダ.Files
        If FSO.GetExtensionName(ファイル.Name) Like "xls*" Then
        
            ' 読み取り専用で開く
            Dim wb取込ブック As Workbook
            Set wb取込ブック = Workbooks.Open(ファイル.Path, , True)
            
            ' ■ ブックごとの処理
            Call ブックごとの処理(wb取込ブック)
        
            ' 保存せず閉じる
            wb取込ブック.Close False
        
        End If
    Next
    
    Set ws出力シート = Nothing
End Sub

' ブックごとの処理
Private Sub ブックごとの処理(wb取込ブック As Workbook)
    
    ' 対象シートを取得 (なければExit)
    If Isシートが存在する(対象年月, wb取込ブック) = False Then Exit Sub
    Dim ws取込シート As Worksheet
    Set ws取込シート = wb取込ブック.Worksheets(対象年月)
    
    ' 出力シートの最終行の次行を取得
    Dim 貼付起点セル As Range
    Set 貼付起点セル = ws出力シート.Cells(Get最終行(ws出力シート) + 1, 1)
    
    ' 取込シートのUsedRangeから見出しを除去
    Dim コピーエリア As Range
    Set コピーエリア = GetUsedRange指定行以下(ws取込シート, 2)
    
    ' コピーを実行
    If Not コピーエリア Is Nothing Then
        コピーエリア.Copy 貼付起点セル
    End If
        
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' UsedRangeのカット
Function GetUsedRange指定行以下(対象シート As Worksheet, 指定行 As Long) As Range
    With 対象シート
        Set GetUsedRange指定行以下 = Intersect(.UsedRange, .Rows(指定行).Resize(.UsedRange.Rows.Count))
    End With
End Function

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' シートの存在判定
' 参考：https://www.limecode.jp/entry/utility/existsworksheet
Function Isシートが存在する(判定シート名 As String, 指定ブック As Workbook) As Boolean

    ' ブック内の全シートを走査
    Dim ws As Worksheet
    For Each ws In 指定ブック.Worksheets

        ' シート名が一致したらTrueを返してExit
        If ws.Name = 判定シート名 Then
            Isシートが存在する = True
            Exit Function
        End If

    Next

End Function

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

解説

FileSystemObjectを利用したストレートなフォルダ内のファイルループと、
シート・データエリアの取得 ⇒ セル範囲のコピーという、
基本的なコードを組み合わせたコードです。

メインプロシージャ・サブプロシージャ・汎用関数プロシージャと、
ちょうどいいプロシージャ分割の復習問題と思いました。

頻出コードを汎用関数化1行にすることでコードを見やすくしつつ、
ループの中身を丸ごとプロシージャ化して外に出し、
For Each 文の全体像が見やすくなるように整理してみました。

プロシージャ分割の参考にしてみてください。

ソースコード（ライブラリ使用版）

メインモジュール

' 100本ノック040：複数ブックの統合
Sub フォルダ内の対象年月シートを統合する_()
    
    ' 対象月の指定
    Dim 対象年月 As String: 対象年月 = "2020年12月"
    Set ws出力シート = ThisWorkbook.Worksheets(対象年月)
    
    ' 出力シートをクリア
    Call 指定行より下をすべて削除する(ws出力シート, 2)
    
    ' ■ フォルダ内の全xlsxファイルの対象名シートを結合
    Dim ws統合シート As Worksheet
    Set ws統合シート = 指定フォルダ内のすべてのブックを結合する( _
        "C:\Users\wfsp\Desktop\data", 1, , "xlsx", 対象年月)
    
    ' 本ブックの対象シートへコピーして新規シートは閉じる
    ' ※ ライブラリが新規ブック作成仕様のため
    ws統合シート.UsedRange.Copy ws出力シート.Range("A1")
    ws統合シート.Parent.Close False
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' フォルダ内ファイルの結合
' 参考：https://www.limecode.jp/entry/tools/merge-all-workbooks-in-folder
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

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

解説

「Function 指定フォルダ内のすべてのブックを結合する」という、
万能型の比較的規模が大きい汎用関数を活用したコードです。

メインコードはほぼこの関数のCallで処理が終わっていますね。

この関数は「フォルダパス」「ファイル名条件」「シート名条件」を受け取ってくれるため、「dataフォルダ」「.xls*」「2020年12月」を渡すだけで取込が完了します。

このライブラリは取込ログを出力する機能も持っていますが、
今回は不要なため使用しておりません。

こういったよくある処理を万能型の汎用関数にしておけば、
最初に作るときはかなり時間を割きますが、それに見合う効力があります。

フォルダ内のファイル走査をよく行う方は、
是非ともライブラリに加えてあげてください。