https://www.limecode.jp/entry/fungo/063-merge-multiple-worksheets

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

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

出題：複数シートの連結

#VBA100本ノック 63本目
ブック内には「yyyy年mm月」シートが複数あり全て同一フォーマットです。
(A1開始で空行なく連続している)
これらのシートを一つに統合したシートを作成してください。
ただし1行目は見出し行なので先頭に1回だけの出力にしてください。
※出力シートは先頭に挿入（名称任意）

シートの結合

◇ 出題ページはこちら

ソースコード

メインモジュール

' 100本ノック063：複数シートの連結
Sub 年月別シートを1シートに連結する()
    
    Dim ws出力シート As Worksheet
    Set ws出力シート = 指定ブックの全シートを結合する(ThisWorkbook, 1, "####年##月")
    
    ws出力シート.Name = "結合シート"
    ws出力シート.Move ThisWorkbook.Worksheets(1)
    
End Sub

汎用関数モジュール

Option Explicit

' ブック内シートの結合
' 参考：https://www.limecode.jp/entry/tools/merge-all-Worksheets-in-Workbook
Function 指定ブックの全シートを結合する(wb対象ブック As Workbook, R_見出し行 As Long _
        , Optional ByVal シート名Like条件 As String = "*") As Worksheet
        
    ' 出力するシートは第1シートをコピーして利用
    Dim ws出力シート As Worksheet
    
    ' 開いたブック内の条件合致シートをループ
    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
            
            Else
                
                ' UsedRangeのうち見出し行より下を取得
                Dim コピーエリア As Range
                Set コピーエリア = GetUsedRange指定行以下(ws読取シート, R_見出し行 + 1)
                
                ' コピーを実行
                If Not コピーエリア Is Nothing Then
                    コピーエリア.Copy ws出力シート.Cells(Get最終行(ws出力シート) + 1, コピーエリア.Column)
                End If
            
            End If
    
        End If
    Next ' 開いたブック内の条件合致シートをループ
    
    Set 指定ブックの全シートを結合する = ws出力シート

End Function

' 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