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

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。

最近ではPower Querryという便利なものがあるので、敢えてマクロで行う
必要は無いかもしれない。でも、できるに越したことは無いか。

Sub VBA_100Knock_40()
    ' 各ファイルの転記元シート。
    Dim SrcSheet As Worksheet
    ' 情報集約（転記先）シート。
    Dim DstSheet As Worksheet
    ' 情報集約（転記先）シート名。
    Dim DstSheetName As String: DstSheetName = "2020年12月"
    Set DstSheet = ThisWorkbook.Sheets(DstSheetName)
    
    ' 転記元ファイルが保存されたフォルダパス。
    Dim TargetFolderPath As String
        TargetFolderPath = "C:\temp\新しいフォルダー (2)\data"
    
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' 各転記元ファイル格納用変数。
    Dim Wb As Workbook
    ' 各転記元シート格納用変数。
    Dim Ws As Worksheet
    ' Wb内のシートループ用変数。
    Dim File As Scripting.File
    ' 転記元情報格納用配列。
    Dim SrcArray As Variant
    ' 転記先の左上セルアドレス。
    Dim DstRange As Range
        
        ' 画面更新の一時停止。
        Application.ScreenUpdating = False
        
        ' 転記元の各ファイルについて、拡張子に「.xls」を含むものを起動。
        ' 転記先と同じ名前のシート名が存在したら、その中身を配列に格納する。
        For Each File In FSO.GetFolder(TargetFolderPath).Files
            If FSO.GetExtensionName(File) Like "xls?" Then
                Set Wb = Workbooks.Open(Filename:=File.Path, _
                                        UpdateLinks:=False, _
                                        ReadOnly:=True)
                    SrcArray = Array()
                    For Each Ws In Wb.Sheets
                        If Ws.Name = DstSheetName Then
                            Set SrcSheet = Ws
                                SrcArray = Ws.UsedRange
                                Exit For
                        End If
                    Next
                    
                    Wb.Close False
                    ThisWorkbook.Activate
                    
                    If UBound(SrcArray) <> -1 Then
                        ' 一つ目の転記情報。
                        If DstSheet.Range("A1") = vbNullString Then
                            Set DstRange = DstSheet.Range("A1")
                        ' 二つ目以降の転記情報。
                        Else
                            Set DstRange = DstSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)
                            ' 空白を目印に二つ目以降のラベル行を纏めて削除するために、
                            ' 配列（１，１）を空白にする。
                            SrcArray(1, 1) = vbNullString
                        End If
                        DstRange.Resize(UBound(SrcArray), UBound(SrcArray, 2)) = SrcArray
                    End If
            End If
        Next
        
        ' 空白が無い場合はエラーになるので、一旦エラー無視。
        On Error Resume Next
        DstRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
        
        Application.ScreenUpdating = True
End Sub

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。