和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > 100本ノック > ExcelVBA100本ノック解答用汎用関数集

ExcelVBA100本ノック解答用汎用関数集

100本ノック 汎用関数集 VBA

本ブログでは、Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答を順次公開しております。

この100本ノックに取り組むにあたり、

  • 解答の際になるべく汎用関数を作り、各問題で共有する

というルールを設けております。


100番から逆順に解くという謎ルールでもやっており、
現在100～88までの解答が終わりました。


各解答ページには使った関数だけを載せていますが、
すべての汎用関数をまとめたモジュールも便利かと思い本ページに公開します。

モジュールごと個人用マクロブックに入れておき、
そのままドラッグ&ドロップでマクロファイルに入れるなどしてご活用ください。

100本ノックで使用した汎用関数集

Option Explicit

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

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
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/syntax/check-mergecells-mergearea
Function Is結合先頭セル(判定セル As Range) As Boolean
    Is結合先頭セル = (判定セル.MergeCells And 判定セル.Address = 判定セル.MergeArea.Cells(1, 1).Address)
End Function
Function Is結合内部セル(判定セル As Range) As Boolean
    Is結合内部セル = (判定セル.MergeCells And 判定セル.Address <> 判定セル.MergeArea.Cells(1, 1).Address)
End Function
Function Is結合セル全体(判定エリア As Range) As Boolean
    Is結合セル全体 = (判定エリア.MergeCells And 判定エリア.Address = 判定エリア.Cells(1, 1).MergeArea.Address)
End Function

' 改行文字の置き換え
' 参考：https://www.limecode.jp/entry/syntax/linebreak-vbcrlf-vbcr-vblf
Function 文中改行を指定文字に置き換える(元テキスト As String, Optional 置換テキスト As String = " ") As String

    Dim 結果テキスト As String
    結果テキスト = Replace(元テキスト, vbCrLf, 置換テキスト)
    結果テキスト = Replace(結果テキスト, vbCr, 置換テキスト)
    結果テキスト = Replace(結果テキスト, vbLf, 置換テキスト)

    文中改行を指定文字に置き換える = 結果テキスト

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

' 最終行の取得
' 参考：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/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R 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最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

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

End Function

' 行番号の検索
' ◆ ブログ未掲載
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1

End Function

' 列番号の検索
' ◆ ブログ未掲載
Function Match列番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Match列番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Column - 1
    Else
        Match列番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Column - 1
    End If
End Function

' データ件数
' ◆ ブログ未掲載
Function Countデータ件数(対象シート As Worksheet) As Long
    If 対象シート.AutoFilterMode = False Then Exit Function
    With 対象シート.AutoFilter.Range
        Countデータ件数 = .Rows.Count + .Row - 2
    End With
End Function

' 各列のデータ部分
' 参考：https://www.limecode.jp/entry/utility/get-column-data-range
Function GetRange指定列のデータ部分(対象シート As Worksheet, 対象列 As Long) As Range
    If Countデータ件数(対象シート) = 0 Then Exit Function
    Set GetRange指定列のデータ部分 = 対象シート.Cells(対象シート.AutoFilter.Range.Row + 1, 対象列) _
                                                            .Resize(Countデータ件数(対象シート))
End Function

' フィルターデータ部
' 参考：https://www.limecode.jp/entry/utility/get-autofilter-datarange
Function GetRangeフィルターデータ部分(指定シート As Worksheet) As Range
    If 指定シート.AutoFilterMode = False Then Exit Function
    
    Dim フィルターデータ部 As Range
    Set フィルターデータ部 = 指定シート.AutoFilter.Range
    
    If フィルターデータ部.Rows.Count = 1 Then Exit Function
    
    Set フィルターデータ部 = フィルターデータ部.Offset(1)
    Set フィルターデータ部 = フィルターデータ部.Resize(フィルターデータ部.Rows.Count - 1)
    
    Set GetRangeフィルターデータ部分 = フィルターデータ部

End Function

' エリアの拡大縮小
' 参考：https://www.limecode.jp/entry/utility/expand-range
Function Resizeエリアの拡大縮小(指定エリア As Range, Optional R上方向 As Long = 0, Optional R下方向 As Long = 0 _
    , Optional C左方向 As Long = 0, Optional C右方向 As Long = 0) As Range
    On Error Resume Next
    With 指定エリア
        Set Resizeエリアの拡大縮小 = .Resize(.Rows.Count + R上方向 + R下方向, .Columns.Count + C左方向 + C右方向)
    End With
    Set Resizeエリアの拡大縮小 = Resizeエリアの拡大縮小.Offset(-R上方向, -C左方向)
End Function

' 不要行の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-quickly
Sub 指令列がTRUEの行を高速削除する(データエリア全体 As Range, 判定列 As Long)

    Dim ws対象シート As Worksheet: Set ws対象シート = データエリア全体.Worksheet

    Dim column判定列 As Range
    Set column判定列 = Intersect(データエリア全体, ws対象シート.Columns(判定列))
    If column判定列 Is Nothing Then Exit Sub

    Dim RCount削除行数 As Long
    RCount削除行数 = Fx.CountIf(column判定列, True)
    If RCount削除行数 = 0 Then Exit Sub

    ' ソートしてTRUEを1エリアにまとめる
    データエリア全体.Sort ws対象シート.Cells(1, 判定列)

    ' 第1TRUE行から削除行数分を削除
    Dim R1st削除開始行 As Long
    R1st削除開始行 = Match行番号(True, column判定列)
    ws対象シート.Rows(R1st削除開始行).Resize(RCount削除行数).Delete

End Sub

' 値のコピー
' 参考：https://www.limecode.jp/entry/syntax/rangecopy-pastevalues
Sub 値をコピーする(コピー元基準セルまたはエリア As Range, ペースト基準セル As Range _
    , Optional ByVal エリア高 As Long = -1, Optional ByVal エリア幅 As Long = -1)
    
    ' ◇ エリアサイズの省略時は、コピーエリアのサイズを取得
    If エリア高 = -1 Then エリア高 = コピー元基準セルまたはエリア.Rows.Count
    If エリア幅 = -1 Then エリア幅 = コピー元基準セルまたはエリア.Columns.Count
    
    ' 値をコピー
    ペースト基準セル.Resize(エリア高, エリア幅).Value = コピー元基準セルまたはエリア.Resize(エリア高, エリア幅).Value

End Sub

' シート数式計算
' 参考：https://www.limecode.jp/entry/syntax/formula
Sub シート数式で計算する(計算エリア As Range, シート数式 As String)
    計算エリア.Formula = シート数式
    計算エリア.Value = 計算エリア.Value
End Sub

' 文字列検索切り出しLeft/Right/Mid
' 参考：https://www.limecode.jp/entry/library/string-manipulation
Function Left文字列まで(ByVal 元テキスト As String, ByVal 検索値 As String _
    , Optional is検索値を結果に含む As Boolean = False) As String

    Dim instr位置 As Long: instr位置 = InStr(元テキスト, 検索値)
    If instr位置 > 0 Then
        Left文字列まで = Left(元テキスト, instr位置 - 1) & IIf(is検索値を結果に含む, 検索値, "")
    End If

End Function
Function Right文字列まで(ByVal 元テキスト As String, ByVal 検索値 As String _
    , Optional is検索値を結果に含む As Boolean = False) As String

    Dim instrRev位置 As Long: instrRev位置 = InStrRev(元テキスト, 検索値)
    If instrRev位置 > 0 Then
        Right文字列まで = IIf(is検索値を結果に含む, 検索値, "") _
                                          & Mid(元テキスト, instrRev位置 + Len(検索値))
    End If

End Function
Function Mid文字列から文字列(ByVal 元テキスト As String, ByVal 前検索値 As String, ByVal 後検索値 As String _
    , Optional is前検索値を結果に含む As Boolean = False, Optional is後検索値を結果に含む As Boolean = False) As String

    Dim instr前値 As Long: instr前値 = InStr(元テキスト, 前検索値)
    If instr前値 = 0 Then Exit Function

    Dim instr後値 As Long: instr後値 = InStr(instr前値 + Len(前検索値) + 1, 元テキスト, 後検索値)
    If instr後値 = 0 Then Exit Function

    Mid文字列から文字列 = _
        IIf(is前検索値を結果に含む, 前検索値, "") & _
        Mid(元テキスト, instr前値 + Len(前検索値), instr後値 - instr前値 - Len(前検索値)) & _
        IIf(is後検索値を結果に含む, 後検索値, "")

End Function

' RGB⇔HTMLカラーコード相互変換
' 参考：https://www.limecode.jp/entry/utility/convert-rgb-html-colorcode
Function ConvRGB値→HTMLカラーコード(RGB値 As Long) As String
    Dim RGBHex値 As String
    RGBHex値 = Right("000000" & Hex(RGB値), 6)
    ConvRGB値→HTMLカラーコード = Right(RGBHex値, 2) _
                                             & Mid(RGBHex値, 3, 2) _
                                             & Left(RGBHex値, 2)
End Function

Function ConvHTMLカラーコード→RGB値(HTMLカラーコード As String) As Long
    ConvHTMLカラーコード→RGB値 = RGB("&H" & Left(HTMLカラーコード, 2) _
                                                        , "&H" & Mid(HTMLカラーコード, 3, 2) _
                                                        , "&H" & Right(HTMLカラーコード, 2))
End Function

' 配列の要素数の取得
' 参考：https://www.limecode.jp/entry/syntax/ubound-lbound-count-array-elemens
Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

' 配列の次元数の取得
' 参考：https://www.limecode.jp/entry/utility/get-array-dimension
Function Get配列の次元数(Arr As Variant) As Long

    ' 渡された変数が配列ではない場合は0を返すこととする
    If IsArray(Arr) = False Then Get配列の次元数 = 0: Exit Function

    ' エラーが出るまでUBoundを取得してみる
    Dim tmp
    Dim 次元数 As Long: 次元数 = 0
    On Error Resume Next
    Do While Err.Number = 0
        次元数 = 次元数 + 1
        tmp = UBound(Arr, 次元数)
    Loop
    On Error GoTo 0

    ' エラーが出たひとつ前の次元が求める次元数
    Get配列の次元数 = 次元数 - 1

End Function

' 一次元配列 → セル
' 参考：https://www.limecode.jp/entry/utility/output-array-to-range
Sub 一次元配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant _
    , Optional is縦方向へ出力 As Boolean = True)

    Dim 要素数 As Long: 要素数 = Count配列の要素数(Arr出力配列)
    If is縦方向へ出力 Then
        出力始点セル.Resize(要素数, 1).Value _
            = GetArray一次元配列→n行1列の二次元配列(Arr出力配列)
    Else
        出力始点セル.Resize(1, 要素数).Value = Arr出力配列
    End If
    
End Sub

' 二次元配列 → セル
' 参考：https://www.limecode.jp/entry/utility/output-array-to-range
Sub 二次元配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant)

    出力始点セル.Resize(Count配列の要素数(Arr出力配列, 1) _
                              , Count配列の要素数(Arr出力配列, 2)).Value = Arr出力配列

End Sub

' Transpose上限対応用関数
' 参考：https://www.limecode.jp/entry/utility/output-array-to-range
Function GetArray一次元配列→n行1列の二次元配列(Arr As Variant) As Variant
    
    Dim 生成配列()
    ReDim 生成配列(LBound(Arr) To UBound(Arr), 1 To 1)
    
    Dim i As Long
    For i = LBound(Arr) To UBound(Arr)
        生成配列(i, 1) = Arr(i)
    Next
    
    GetArray一次元配列→n行1列の二次元配列 = 生成配列
    
End Function

' 配列を新規シートに出力する
' 参考：https://www.limecode.jp/entry/debug/display-array-on-newsheet
Sub 配列を新規シートに出力する(Arr)
    Workbooks.Add.Worksheets(1).Range("A1") _
        .Resize(Count配列の要素数(Arr, 1), Count配列の要素数(Arr, 2)) = Arr
End Sub

' Dictionary(Item:配列) → セル
' 参考：https://www.limecode.jp/entry/utility/convert-jagarray-to-2d-array
Sub Itemが一次元配列のDictionaryをセルに出力する(出力始点セル As Range, Dic As Dictionary)

    Dim Arr: Arr = GetArr二次元配列←ジャグ配列(Dic.Items)
    Call 二次元配列をセルに出力する(出力始点セル, Arr)

End Sub

' 二次元配列←ジャグ配列
' 参考：https://www.limecode.jp/entry/utility/convert-jagarray-to-2d-array
Function GetArr二次元配列←ジャグ配列(Arrジャグ配列 As Variant) As Variant

    Dim i As Long, j As Long ' ジャグ配列のインデックス
    Dim R As Long, C As Long ' 二次元配列のインデックス

    Dim Arr出力配列()

    Dim 最大要素数 As Long: 最大要素数 = 0

    ' 配列内の配列の中で最も大きい要素数を取得
    For i = LBound(Arrジャグ配列) To UBound(Arrジャグ配列)

        Dim 現要素数 As Long: 現要素数 = Count配列の要素数(Arrジャグ配列(i))
        If 現要素数 >= 最大要素数 Then 最大要素数 = 現要素数

    Next

    ' 出力二次元配列を準備
    ReDim Arr出力配列(1 To Count配列の要素数(Arrジャグ配列), 1 To 最大要素数)

    ' 全要素を代入
    R = 1
    For i = LBound(Arrジャグ配列) To UBound(Arrジャグ配列)
        C = 1
        For j = LBound(Arrジャグ配列(i)) To UBound(Arrジャグ配列(i))

            If IsObject(Arrジャグ配列(i)(j)) Then
                Set Arr出力配列(R, C) = Arrジャグ配列(i)(j)
            Else
                Let Arr出力配列(R, C) = Arrジャグ配列(i)(j)
            End If

            C = C + 1
        Next
        R = R + 1
    Next

    GetArr二次元配列←ジャグ配列 = Arr出力配列

End Function

' セルのリストを1次元配列に
' 参考：https://www.limecode.jp/entry/utility/getarray-from-rangeobject
Function GetArrayセルのリストを1次元配列に変換する(セルリスト As Range) As Variant

    ' ◇ 単セル → 値そのまま
    If セルリスト.Cells.Count = 1 Then
        GetArrayセルのリストを1次元配列に変換する = Array(セルリスト.Value)
        Exit Function
    End If

    ' 1列データの時はTransposeで高速化
    If セルリスト.Areas.Count = 1 And セルリスト.Columns.Count = 1 And セルリスト.Count <= 65535 Then
        GetArrayセルのリストを1次元配列に変換する = Fx.Transpose(セルリスト)
        Exit Function
    End If

    ' それ以外は1セルずつ値を格納
    Dim Arr生成配列() As Variant
    ReDim Arr生成配列(1 To セルリスト.Cells.Count) As Variant

    Dim i As Long: i = 1
    Dim Cell As Range
    For Each Cell In セルリスト.Cells
        Arr生成配列(i) = Cell.Value
        i = i + 1
    Next

    GetArrayセルのリストを1次元配列に変換する = Arr生成配列

End Function

' Dictionaryを新規シートに出力する
' 参考：https://www.limecode.jp/entry/debug/display-dictionary-on-newsheet
Sub Dictionaryを新規シートに出力する(Dic As Dictionary)
    With Workbooks.Add.Worksheets(1)
        Call 一次元配列をセルに出力する(.Range("A1"), Dic.Keys)
        Call 一次元配列をセルに出力する(.Range("B1"), Dic.Items)
    End With
End Sub

' シートをファイル分割
' ◆ ブログ未掲載
Function シートを要素ごとにファイル分割する(ws対象シート As Worksheet, 分割対象列 As Long, 見出し行 As Long _
    , Path出力先フォルダ As String, ブック名接頭部 As String) As Worksheet

    ' テンプレートシートを作成
    ws対象シート.Copy
    Dim wsテンプレート As Worksheet: Set wsテンプレート = ActiveSheet
    wsテンプレート.Name = "wsテンプレート"
    Call 指定行より下をすべて削除する(wsテンプレート, 見出し行 + 1)

    ' 対象シートのコピーを作成
    ws対象シート.Copy
    Dim wsコピー元データ As Worksheet
    Set wsコピー元データ = ActiveSheet
    wsコピー元データ.Name = "wsコピー元データ"
    
    ' コピー元データの見出し行より下を分割対象列でソート
    GetUsedRange指定行以下(wsコピー元データ, 見出し行 + 1).Sort wsコピー元データ.Cells(1, 分割対象列)

    ' データエリアを走査
    Dim R_コピー開始行 As Long: R_コピー開始行 = 見出し行 + 1
    Dim R_コピー最終行 As Long
    Dim R As Long
    For R = 見出し行 + 2 To Get最終行(wsコピー元データ)

        ' 対象列の要素が切り替わったタイミングでシートを複製
        If wsコピー元データ.Cells(R, 分割対象列) <> wsコピー元データ.Cells(R + 1, 分割対象列) _
        Or R = Get最終行(wsコピー元データ) Then
            R_コピー最終行 = R
            
            Dim ws分割シート As Worksheet
            wsテンプレート.Copy
            Set ws分割シート = ActiveSheet
            
            Range(wsコピー元データ.Rows(R_コピー開始行), wsコピー元データ.Rows(R_コピー最終行)) _
                .Copy ws分割シート.Cells(見出し行 + 1, 1)
                
            ws分割シート.Parent.SaveAs Path出力先フォルダ & "\" & ブック名接頭部 & "(" & wsコピー元データ.Cells(R, 分割対象列) & ").xlsx"
            
            ws分割シート.Parent.Close False
            
            R_コピー開始行 = R + 1
            R_コピー最終行 = 0
            
        End If

    Next

    wsコピー元データ.Parent.Close False
    wsテンプレート.Parent.Close False

End Function

' フォルダ内ファイルの結合
' 参考：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

' 新規フォルダ作成(連番付)
' 参考：https://www.limecode.jp/entry/utility/mkdir-addserialnumber
Function 連番を付与して新規フォルダを作成する(Path親フォルダ As String, 作成フォルダ名 As String _
    , Optional is第1フォルダにも1を付番する As Boolean = False) As String
    
    ' 連番なしのフォルダパス
    Dim path作成フォルダベース As String
    path作成フォルダベース = Path親フォルダ & "\" & 作成フォルダ名
    
    ' 実際に作成するフォルダパス
    Dim path作成フォルダ As String
    If is第1フォルダにも1を付番する Then
        path作成フォルダ = path作成フォルダベース & "-1"
    Else
        path作成フォルダ = path作成フォルダベース
    End If
    
    ' 第1フォルダがなければ作成してExit
    If Dir(path作成フォルダ, vbDirectory) = "" Then
        MkDir path作成フォルダ
        連番を付与して新規フォルダを作成する = path作成フォルダ
        Exit Function
    End If

    ' フォルダの無い番号まで連番を進める
    Dim i As Long: i = 2
    Do While Dir(path作成フォルダベース & "-" & i, vbDirectory) <> ""
        i = i + 1
    Loop

    ' フォルダを作成
    path作成フォルダ = path作成フォルダベース & "-" & i
    MkDir path作成フォルダ
    連番を付与して新規フォルダを作成する = path作成フォルダ

End Function

' 自動更新の停止
Sub エクセルの自動更新を停止する(isブック計算をOFFに As Boolean _
    , Optional is画面更新をOFFに As Boolean = True _
    , Optional isイベントをOFFに As Boolean = True)

    If isブック計算をOFFに Then Application.Calculation = xlCalculationManual
    If is画面更新をOFFに Then Application.ScreenUpdating = False
    If isイベントをOFFに Then Application.EnableEvents = False

End Sub

' 自動更新の開始
Sub エクセルの自動更新を開始する()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
        .DisplayAlerts = True
    End With
End Sub

' Accessテーブルの取込
' 参考：https://www.limecode.jp/entry/utility/export-access-table-to-worksheet
Sub Accessの指定テーブルをセルに出力する(Accessファイルパス As String, テーブル名 As String _
    , 出力起点セル As Range, is見出しも出力する As Boolean)

    Dim 接続 As Object: Set 接続 = CreateObject("ADODB.Connection")
    接続.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Accessファイルパス & ";"

    Dim レコードセット As Object: Set レコードセット = CreateObject("ADODB.Recordset")
    レコードセット.Open "SELECT * FROM " & テーブル名, 接続

    ' フィールド名を第1行に出力
    If is見出しも出力する Then
        Dim C As Long
        For C = 1 To レコードセット.Fields.Count
            出力起点セル.Cells(1, C).Value = レコードセット.Fields(C - 1).Name
        Next
    End If

    ' 第2行以降に全レコードを出力
    出力起点セル.Cells(IIf(is見出しも出力する, 2, 1), 1).CopyFromRecordset レコードセット

    レコードセット.Close: Set レコードセット = Nothing
    接続.Close: Set 接続 = Nothing

End Sub

' QueryTableによるWEB読み込みの汎用関数
' 参考：https://www.limecode.jp/entry/utility/querytables-import-web-table
Sub QueryTableでWEB上の表を読み込む(出力起点セル As Range _
    , 対象URL As String, Optional テーブルNo As Long = -1 _
    , Optional is書式リンク含む As Boolean = False, Optional is日付に変換する As Boolean = False)

    With 出力起点セル.Worksheet.QueryTables.Add("URL;" & 対象URL, 出力起点セル)

        If テーブルNo = -1 Then ' テーブルNo省略時は全テーブルを対象
            .WebSelectionType = xlAllTables
        Else
            .WebTables = xlSpecifiedTables
            .WebTables = テーブルNo
        End If
        .WebFormatting = IIf(is書式リンク含む, xlWebFormattingAll, xlWebFormattingNone)
        .WebDisableDateRecognition = Not (is日付に変換する)

        .Refresh BackgroundQuery:=False
        .Delete
    End With

End Sub