エクセルブック比較エビンデス作成ツール

前回作成したツールをもう少しブラッシュアップさせてみました。

Option Explicit
'==========================================================
' シートUI版：Excel差分ツール（図形＋セルのみ／フォルダ内の同名ファイルを一括比較）
'  - UIシートを自動生成（DiffUI）
'  - B2: Target1（基準フォルダパス） / B3: Target2（比較フォルダパス）
'  - 出力はA5:E5見出し、A6以降に表で書き出し（ファイル/シート/セル/列見出し/不一致理由）
'  - 図形ボタン3つ（参照1/参照2/比較実行）を自動配置しマクロ割当
'  - 同名ブック同時オープン対策：比較側を一時コピーして開く
'  - 「同じブックを出力する前提」で全シート・全行列を比較してミス検出
'  - 変数命名：型3文字 + "_" + 日本語（定数は全大文字）
'  - v2 変更点：
'      * C列をセルアドレス（例 A4, AB65）に変更
'      * E5 見出しを「不一致理由」に変更
'      * 不一致理由を 1.値不一致 / 2.関数不一致 / 3.書式不一致（型含む）/ 4.シートの過不足 で出力
'      * シート比較モード追加：同名シートで比較 or 左から順に比較
'==========================================================

'==== オプション ====
Private Const DBL_許容誤差 As Double = 0.000001        ' 数値差の許容（例：1e-6）
Private Const BOOL_大文字小文字区別 As Boolean = False  ' 文字比較で大小区別するか
Private Const BOOL_TRIM比較 As Boolean = True            ' 文字列前後空白を無視するか
Private Const STR_拡張子パターン As String = "*.xlsx;*.xlsm" ' 必要なら ;*.xls を追加
Private Const BOOL_日付同値扱い As Boolean = False       ' 日付表記ゆれ（yyyy/mm/dd と dd/mm/yyyy 等）を同値扱いするか
Private Const BOOL_書式差分検出 As Boolean = False       ' 値一致でも NumberFormat の違いを差分検出（既定OFF）
Private Const BOOL_シート名で比較 As Boolean = True      ' True: 同名シート / False: 左から順

'****
' プロシージャー概要：UIシート作成
'****
Public Sub 作成_UIシート()
    Dim ws_UI As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("DiffUI").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set ws_UI = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws_UI.Name = "DiffUI"

    With ws_UI
        .Range("A1").Value = "Excel差分ツール（フォルダ比較：全ファイル×全シート）"
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Size = 14

        .Range("A2").Value = "Target1（基準フォルダ）"
        .Range("A3").Value = "Target2（比較フォルダ）"
        .Range("B2:B3").ClearContents
        .Range("B2:B3").NumberFormatLocal = "@"
        .Range("B2:B3").ColumnWidth = 80

        .Range("A5").Value = "ファイル"
        .Range("B5").Value = "シート"
        .Range("C5").Value = "セル"
        .Range("D5").Value = "列見出し"
        .Range("E5").Value = "不一致理由"
        .Range("A5:E5").Font.Bold = True
        .Columns("A").ColumnWidth = 38
        .Columns("B").ColumnWidth = 28
        .Columns("C").ColumnWidth = 12
        .Columns("D").ColumnWidth = 28
        .Columns("E").ColumnWidth = 70
    End With

    ' 既存図形を掃除
    Dim shp_既存 As Shape
    For Each shp_既存 In ws_UI.Shapes
        shp_既存.Delete
    Next shp_既存

    ' 図形ボタン：参照1 / 参照2 / 比較実行
    追加_ボタン図形 ws_UI, "btnRef1", "参照1（基準フォルダ）", 20, 34, 160, 24, "RefFolder1_Click_Sheet"
    追加_ボタン図形 ws_UI, "btnRef2", "参照2（比較フォルダ）", 190, 34, 160, 24, "RefFolder2_Click_Sheet"
    追加_ボタン図形 ws_UI, "btnDiff", "比較実行（全ファイル×全シート）", 360, 34, 230, 24, "DiffFolders_Click_Sheet"

    MsgBox "UIシートを作成しました。B2に基準フォルダ、B3に比較フォルダを参照ボタンで設定し、『比較実行（全ファイル×全シート）』を押してください。", vbInformation
End Sub

'****
' プロシージャー概要：図形ボタンを追加
' 引数：ws_対象, str_名前, str_表示名, sng_Left, sng_Top, sng_Width, sng_Height, str_マクロ名
'****
Private Sub 追加_ボタン図形(ByVal ws_対象 As Worksheet, ByVal str_名前 As String, ByVal str_表示名 As String, _
                         ByVal sng_Left As Single, ByVal sng_Top As Single, ByVal sng_Width As Single, _
                         ByVal sng_Height As Single, ByVal str_マクロ名 As String)
    Dim shp_ボタン As Shape
    Set shp_ボタン = ws_対象.Shapes.AddShape(msoShapeRoundedRectangle, sng_Left, sng_Top, sng_Width, sng_Height)
    With shp_ボタン
        .Name = str_名前
        .TextFrame2.TextRange.Text = str_表示名
        .Fill.ForeColor.RGB = RGB(230, 230, 250)
        .Line.ForeColor.RGB = RGB(120, 120, 160)
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame2.VerticalAnchor = msoAnchorMiddle
        .OnAction = "'" & ThisWorkbook.Name & "'!" & str_マクロ名
    End With
End Sub

'****
' プロシージャー概要：基準フォルダ参照
'****
Public Sub RefFolder1_Click_Sheet()
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_パス As String
    str_パス = 取得_フォルダパス("基準フォルダを選択")
    If Len(str_パス) > 0 Then ws_UI.Range("B2").Value = str_パス
End Sub

'****
' プロシージャー概要：比較フォルダ参照
'****
Public Sub RefFolder2_Click_Sheet()
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_パス As String
    str_パス = 取得_フォルダパス("比較フォルダを選択")
    If Len(str_パス) > 0 Then ws_UI.Range("B3").Value = str_パス
End Sub

'****
' プロシージャー概要：フォルダ内の同名Excelを一括比較
'****
Public Sub DiffFolders_Click_Sheet()
    On Error GoTo ERR_HANDLER

    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_基準Dir As String: str_基準Dir = Trim$(CStr(ws_UI.Range("B2").Value))
    Dim str_比較Dir As String: str_比較Dir = Trim$(CStr(ws_UI.Range("B3").Value))

    ' 既存出力をクリア
    ws_UI.Range("A6:E" & Rows.Count).ClearContents

    If Len(str_基準Dir) = 0 Or Len(str_比較Dir) = 0 Then
        ws_UI.Range("A6").Value = "Target1/Target2 のフォルダパスを指定してください。"
        Exit Sub
    End If
    If Dir(str_基準Dir, vbDirectory) = "" Then
        ws_UI.Range("A6").Value = "基準フォルダが見つかりません: " & str_基準Dir
        Exit Sub
    End If
    If Dir(str_比較Dir, vbDirectory) = "" Then
        ws_UI.Range("A6").Value = "比較フォルダが見つかりません: " & str_比較Dir
        Exit Sub
    End If

    ' 基準側の対象ファイル一覧
    Dim col_ファイル As Collection
    Set col_ファイル = 取得_対象ファイル一覧(str_基準Dir, STR_拡張子パターン)

    If col_ファイル Is Nothing Or col_ファイル.Count = 0 Then
        ws_UI.Range("A6").Value = "基準フォルダにExcelブックが見つかりませんでした。"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim var_名 As Variant, lng_出力行 As Long
    lng_出力行 = 6

    For Each var_名 In col_ファイル
        Dim str_ファイル名 As String: str_ファイル名 = CStr(var_名)
        Dim str_基準パス As String: str_基準パス = str_基準Dir & "\" & str_ファイル名
        Dim str_比較パス As String: str_比較パス = str_比較Dir & "\" & str_ファイル名

        If Dir(str_比較パス) = "" Then
            ' 比較側に同名ファイルなし（理由：シートの過不足 → ファイルレベル）
            ws_UI.Cells(lng_出力行, 1).Value = str_ファイル名
            ws_UI.Cells(lng_出力行, 2).Value = "-"
            ws_UI.Cells(lng_出力行, 3).Value = ""
            ws_UI.Cells(lng_出力行, 4).Value = ""
            ws_UI.Cells(lng_出力行, 5).Value = "シートの過不足：比較側に同名ファイルが存在しません"
            lng_出力行 = lng_出力行 + 1
        Else
            ' 比較側を一時コピーして開く（同名同時オープン対策）
            Dim str_比較開くパス As String
            str_比較開くパス = 作成_比較側一時コピーパス(str_比較パス)

            Dim wb_基準 As Workbook, wb_比較 As Workbook
            On Error GoTo FILE_OPEN_ERR
            Set wb_基準 = Workbooks.Open(str_基準パス, ReadOnly:=True)
            Set wb_比較 = Workbooks.Open(str_比較開くパス, ReadOnly:=True)
            On Error GoTo ERR_HANDLER

            ' 全シート比較（配列：{シート名, セル番地, 見出し, 理由}）
            Dim col_差分 As Collection
            Set col_差分 = 比較_全シート差分_構造(wb_基準, wb_比較)

            If col_差分 Is Nothing Then
                ws_UI.Cells(lng_出力行, 1).Value = str_ファイル名
                ws_UI.Cells(lng_出力行, 5).Value = "内部エラー（差分リスト）"
                lng_出力行 = lng_出力行 + 1
            ElseIf col_差分.Count = 0 Then
                ws_UI.Cells(lng_出力行, 1).Value = str_ファイル名
                ws_UI.Cells(lng_出力行, 5).Value = "差分なし"
                lng_出力行 = lng_出力行 + 1
            Else
                Dim var_項目 As Variant
                For Each var_項目 In col_差分
                    ' var_項目 = Array(シート名 As String, セル番地 As String, 見出し As String, 理由 As String)
                    ws_UI.Cells(lng_出力行, 1).Value = str_ファイル名
                    ws_UI.Cells(lng_出力行, 2).Value = CStr(var_項目(0))
                    ws_UI.Cells(lng_出力行, 3).Value = CStr(var_項目(1))
                    ws_UI.Cells(lng_出力行, 4).Value = CStr(var_項目(2))
                    ws_UI.Cells(lng_出力行, 5).Value = CStr(var_項目(3))
                    lng_出力行 = lng_出力行 + 1
                Next var_項目
            End If

            ' 後片付け
            wb_基準.Close SaveChanges:=False
            wb_比較.Close SaveChanges:=False
            削除_一時ファイル安全 str_比較開くパス
        End If
        ' 次のファイルへ
        GoTo NEXT_FILE

FILE_OPEN_ERR:
        ' 開けなかったときの記録
        ws_UI.Cells(lng_出力行, 1).Value = str_ファイル名
        ws_UI.Cells(lng_出力行, 5).Value = "ファイルを開けませんでした"
        lng_出力行 = lng_出力行 + 1
        On Error GoTo ERR_HANDLER
        削除_一時ファイル安全 str_比較開くパス
NEXT_FILE:
    Next var_名

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub

ERR_HANDLER:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ws_UI.Range("A6").Value = "エラー: " & Err.Number & " / " & Err.Description
End Sub

'****
' プロシージャー概要：全シート差分を収集
' 引数：wb_基準, wb_比較
' 戻り値：Collection（{シート名, セル番地, 見出し, 理由} の配列）
'****
Private Function 比較_全シート差分_構造(ByVal wb_基準 As Workbook, ByVal wb_比較 As Workbook) As Collection
    On Error GoTo ERR_HANDLER

    Dim col_結果 As New Collection

    If BOOL_シート名で比較 Then
        Dim ws_基準 As Worksheet
        ' (1) 基準側の各シートを比較（同名）
        For Each ws_基準 In wb_基準.Worksheets
            Dim str_名 As String: str_名 = ws_基準.Name

            Dim ws_比較 As Worksheet
            Set ws_比較 = Nothing
            On Error Resume Next
            Set ws_比較 = wb_比較.Worksheets(str_名)
            On Error GoTo 0

            If ws_比較 Is Nothing Then
                col_結果.Add Array(str_名, "", "", "シートの過不足：比較側に同名シートが存在しません")
            Else
                追加_1シート差分 col_結果, ws_基準, ws_比較
            End If
        Next ws_基準

        ' (2) 比較側にのみ存在するシート
        Dim ws_比較のみ As Worksheet
        For Each ws_比較のみ In wb_比較.Worksheets
            If シート存在有無(wb_基準, ws_比較のみ.Name) = False Then
                col_結果.Add Array(ws_比較のみ.Name, "", "", "シートの過不足：比較側のみ存在")
            End If
        Next ws_比較のみ

    Else
        ' 左から順に（インデックス）比較
        Dim lng_i As Long, lng_n1 As Long, lng_n2 As Long, lng_n As Long
        lng_n1 = wb_基準.Worksheets.Count: lng_n2 = wb_比較.Worksheets.Count
        lng_n = IIf(lng_n1 < lng_n2, lng_n1, lng_n2)
        For lng_i = 1 To lng_n
            追加_1シート差分 col_結果, wb_基準.Worksheets(lng_i), wb_比較.Worksheets(lng_i)
        Next lng_i
        If lng_n1 <> lng_n2 Then
            ' 過不足を理由に追加
            If lng_n1 > lng_n2 Then
                For lng_i = lng_n2 + 1 To lng_n1
                    col_結果.Add Array(wb_基準.Worksheets(lng_i).Name, "", "", "シートの過不足：基準側のみ存在")
                Next lng_i
            Else
                For lng_i = lng_n1 + 1 To lng_n2
                    col_結果.Add Array(wb_比較.Worksheets(lng_i).Name, "", "", "シートの過不足：比較側のみ存在")
                Next lng_i
            End If
        End If
    End If

    Set 比較_全シート差分_構造 = col_結果
    Exit Function

ERR_HANDLER:
    Set 比較_全シート差分_構造 = Nothing
End Function

'****
' プロシージャー概要：1シートの差分を追加
' 引数：col_出力（ByRef）, ws_基準, ws_比較
'****
Private Sub 追加_1シート差分(ByRef col_出力 As Collection, ByVal ws_基準 As Worksheet, ByVal ws_比較 As Worksheet)
    On Error GoTo ERR_HANDLER

    Dim lng_最終行 As Long, lng_最終列 As Long
    lng_最終行 = Application.WorksheetFunction.Max(最終行(ws_基準), 最終行(ws_比較))
    lng_最終列 = Application.WorksheetFunction.Max(最終列(ws_基準), 最終列(ws_比較))

    ' ヘッダ一致チェック（1行目）
    Dim lng_列 As Long
    For lng_列 = 1 To lng_最終列
        If 取得_値(ws_基準.Cells(1, lng_列)) <> 取得_値(ws_比較.Cells(1, lng_列)) Then
            col_出力.Add Array(ws_基準.Name, ws_基準.Cells(1, lng_列).Address(False, False), "ヘッダ", _
                "値不一致：1行目の見出し不一致（" & CStr(取得_値(ws_基準.Cells(1, lng_列))) & _
                " vs " & CStr(取得_値(ws_比較.Cells(1, lng_列))) & ")")
        End If
    Next lng_列

    ' 全体を配列に一括コピー（値）
    Dim var_配列1 As Variant, var_配列2 As Variant
    var_配列1 = ws_基準.Range(ws_基準.Cells(1, 1), ws_基準.Cells(lng_最終行, lng_最終列)).Value
    var_配列2 = ws_比較.Range(ws_比較.Cells(1, 1), ws_比較.Cells(lng_最終行, lng_最終列)).Value

    Dim lng_行 As Long
    For lng_行 = 2 To lng_最終行 ' 1行目はヘッダ
        For lng_列 = 1 To lng_最終列
            Dim str_アドレス As String
            str_アドレス = ws_基準.Cells(lng_行, lng_列).Address(False, False)

            Dim str_理由 As String
            str_理由 = 取得_不一致理由(ws_基準, ws_比較, lng_行, lng_列, var_配列1, var_配列2)
            If Len(str_理由) > 0 Then
                col_出力.Add Array(ws_基準.Name, str_アドレス, CStr(var_配列1(1, lng_列)), str_理由)
            End If
        Next lng_列
    Next lng_行
    Exit Sub

ERR_HANDLER:
    ' 何もしない（呼び出し元で全体エラー扱い）
End Sub

'****
' プロシージャー概要：不一致理由を判定
' 引数：ws_左, ws_右, lng_行, lng_列, var_左配列, var_右配列
' 戻り値：String（空なら一致）
'****
Private Function 取得_不一致理由(ByVal ws_左 As Worksheet, ByVal ws_右 As Worksheet, _
                           ByVal lng_行 As Long, ByVal lng_列 As Long, _
                           ByRef var_左配列 As Variant, ByRef var_右配列 As Variant) As String
    On Error GoTo EH
    Dim str_理由連結 As String

    ' 1) 値の等価
    Dim bool_値一致 As Boolean
    bool_値一致 = 値_等しい(var_左配列(lng_行, lng_列), var_右配列(lng_行, lng_列))
    If Not bool_値一致 Then
        str_理由連結 = 追加理由(str_理由連結, "値不一致（左:" & 表示_値(var_左配列(lng_行, lng_列)) & " / 右:" & 表示_値(var_右配列(lng_行, lng_列)) & ")")
    End If

    ' 2) 関数（数式）不一致：表示値が一致でも、式が違えば検出
    Dim bool_左式 As Boolean, bool_右式 As Boolean
    bool_左式 = ws_左.Cells(lng_行, lng_列).HasFormula
    bool_右式 = ws_右.Cells(lng_行, lng_列).HasFormula
    If bool_左式 Or bool_右式 Then
        Dim str_式左 As String, str_式右 As String
        str_式左 = 安全_数式(ws_左.Cells(lng_行, lng_列))
        str_式右 = 安全_数式(ws_右.Cells(lng_行, lng_列))
        If (str_式左 <> str_式右) Then str_理由連結 = 追加理由(str_理由連結, "関数不一致（左:" & str_式左 & " / 右:" & str_式右 & ")")
    End If

    ' 3) 書式不一致（データ型差 ＋ オプションで表示形式差）
    Dim str_書式詳細 As String
    str_書式詳細 = 取得_書式差異詳細(var_左配列(lng_行, lng_列), var_右配列(lng_行, lng_列), ws_左.Cells(lng_行, lng_列), ws_右.Cells(lng_行, lng_列))
    If Len(str_書式詳細) > 0 Then
        str_理由連結 = 追加理由(str_理由連結, "書式不一致（" & str_書式詳細 & ")")
    End If

    取得_不一致理由 = str_理由連結
    Exit Function
EH:
    取得_不一致理由 = ""
End Function

'****
' プロシージャー概要：理由文字列を結合
'****
Private Function 追加理由(ByVal str_既存 As String, ByVal str_追加 As String) As String
    If Len(str_既存) = 0 Then
        追加理由 = str_追加
    Else
        追加理由 = str_既存 & " / " & str_追加
    End If
End Function

'****
' プロシージャー概要：書式相違の有無判定
' 引数：var_A, var_B, rng_A, rng_B
'****
Private Function 書式相違あり(ByVal var_A As Variant, ByVal var_B As Variant, _
                       ByVal rng_A As Range, ByVal rng_B As Range) As Boolean
    Dim str_差 As String
    str_差 = 取得_書式差異詳細(var_A, var_B, rng_A, rng_B)
    書式相違あり = (Len(str_差) > 0)
End Function

'****
' プロシージャー概要：値の等価判定
' 引数：var_A, var_B
'****
Private Function 値_等しい(ByVal var_A As Variant, ByVal var_B As Variant) As Boolean
    If LenB(var_A) = 0 And LenB(var_B) = 0 Then 値_等しい = True: Exit Function

    If IsNumeric(var_A) And IsNumeric(var_B) Then
        値_等しい = (Abs(CDbl(var_A) - CDbl(var_B)) <= DBL_許容誤差)
        Exit Function
    End If

    If BOOL_日付同値扱い Then
        Dim dbl_dA As Double, dbl_dB As Double
        Dim bool_okA As Boolean, bool_okB As Boolean
        dbl_dA = 解析_日付シリアル(var_A, bool_okA)
        dbl_dB = 解析_日付シリアル(var_B, bool_okB)
        If bool_okA And bool_okB Then
            値_等しい = (Abs(dbl_dA - dbl_dB) <= 0.000000001)
            Exit Function
        End If
    End If

    Dim str_A As String, str_B As String
    str_A = CStr(var_A): str_B = CStr(var_B)
    If BOOL_TRIM比較 Then
        str_A = Trim$(str_A): str_B = Trim$(str_B)
    End If
    If Not BOOL_大文字小文字区別 Then
        str_A = LCase$(str_A): str_B = LCase$(str_B)
    End If
    値_等しい = (str_A = str_B)
End Function

'****
' プロシージャー概要：数式を安全取得
' 引数：rng_対象
'****
Private Function 安全_数式(ByVal rng_対象 As Range) As String
    On Error GoTo EH
    安全_数式 = CStr(rng_対象.Formula)
    Exit Function
EH:
    安全_数式 = ""
End Function

'****
' プロシージャー概要：書式差異の詳細を取得
' 引数：var_A, var_B, rng_A, rng_B
'****
Private Function 取得_書式差異詳細(ByVal var_A As Variant, ByVal var_B As Variant, _
                             ByVal rng_A As Range, ByVal rng_B As Range) As String
    On Error GoTo EH
    Dim col_要素 As Collection: Set col_要素 = New Collection

    Dim str_tA As String, str_tB As String
    str_tA = 型_記述(var_A, rng_A)
    str_tB = 型_記述(var_B, rng_B)
    If str_tA <> str_tB Then col_要素.Add ("型:" & str_tA & " vs " & str_tB)

    If BOOL_書式差分検出 Then
        Dim str_nfA As String, str_nfB As String
        str_nfA = 安全_表示形式(rng_A): str_nfB = 安全_表示形式(rng_B)
        If str_nfA <> str_nfB Then col_要素.Add ("表示形式:" & str_nfA & " vs " & str_nfB)
    End If

    If col_要素.Count = 0 Then
        取得_書式差異詳細 = ""
    Else
        Dim lng_i As Long, str_結 As String
        For lng_i = 1 To col_要素.Count
            If lng_i > 1 Then str_結 = str_結 & ", "
            str_結 = str_結 & CStr(col_要素(lng_i))
        Next lng_i
        取得_書式差異詳細 = str_結
    End If
    Exit Function
EH:
    取得_書式差異詳細 = ""
End Function

'****
' プロシージャー概要：型の日本語ラベル化
' 引数：var_値, rng_セル
'****
Private Function 型_記述(ByVal var_値 As Variant, ByVal rng_セル As Range) As String
    On Error GoTo EH
    If IsNumeric(var_値) Then 型_記述 = "数値": Exit Function
    If IsDate(var_値) Then 型_記述 = "日付": Exit Function
    If VarType(var_値) = vbString Or LenB(var_値) > 0 Then 型_記述 = "文字列": Exit Function
    型_記述 = "その他"
    Exit Function
EH:
    型_記述 = "その他"
End Function

'****
' プロシージャー概要：値の短縮表示
' 引数：var_値
'****
Private Function 表示_値(ByVal var_値 As Variant) As String
    On Error GoTo EH
    Dim str_表示 As String
    str_表示 = CStr(var_値)
    If Len(str_表示) > 64 Then str_表示 = Left$(str_表示, 61) & "..."
    表示_値 = str_表示
    Exit Function
EH:
    表示_値 = ""
End Function

'****
' プロシージャー概要：NumberFormatLocalを安全取得
' 引数：rng_対象
'****
Private Function 安全_表示形式(ByVal rng_対象 As Range) As String
    On Error GoTo EH
    安全_表示形式 = CStr(rng_対象.NumberFormatLocal)
    Exit Function
EH:
    安全_表示形式 = ""
End Function

'****
' プロシージャー概要：最終行取得
' 引数：ws_対象
'****
Private Function 最終行(ByVal ws_対象 As Worksheet) As Long
    With ws_対象.UsedRange
        最終行 = .Row + .Rows.Count - 1
    End With
End Function

'****
' プロシージャー概要：最終列取得
' 引数：ws_対象
'****
Private Function 最終列(ByVal ws_対象 As Worksheet) As Long
    With ws_対象.UsedRange
        最終列 = .Column + .Columns.Count - 1
    End With
End Function

'****
' プロシージャー概要：セル値(Value2)取得
' 引数：rng_セル
'****
Private Function 取得_値(ByVal rng_セル As Range) As Variant
    On Error GoTo EH
    取得_値 = rng_セル.Value2
    Exit Function
EH:
    取得_値 = Empty
End Function

'****
' プロシージャー概要：比較側の一時コピー作成
' 引数：str_元パス
'****
Private Function 作成_比較側一時コピーパス(ByVal str_元パス As String) As String
    On Error GoTo ERR_HANDLER
    Dim str_ファイル名 As String, str_拡張子 As String, str_GUID As String
    str_ファイル名 = Mid$(str_元パス, InStrRev(str_元パス, "\") + 1)
    str_拡張子 = Mid$(str_ファイル名, InStrRev(str_ファイル名, "."))
    str_GUID = Replace(Replace(Replace(Now, " ", "_"), ":", ""), "/", "")
    作成_比較側一時コピーパス = Environ$("TEMP") & "\" & _
                           Left$(str_ファイル名, Len(str_ファイル名) - Len(str_拡張子)) & _
                           "__比較側一時_" & str_GUID & str_拡張子
    FileCopy str_元パス, 作成_比較側一時コピーパス
    Exit Function
ERR_HANDLER:
    作成_比較側一時コピーパス = str_元パス
End Function

'****
' プロシージャー概要：一時ファイルを安全に削除
' 引数：str_パス
'****
Private Sub 削除_一時ファイル安全(ByVal str_パス As String)
    On Error Resume Next
    If Len(str_パス) > 0 Then
        If InStr(1, str_パス, Environ$("TEMP"), vbTextCompare) > 0 Then
            If Dir(str_パス) <> "" Then Kill str_パス
        End If
    End If
    On Error GoTo 0
End Sub

'****
' プロシージャー概要：フォルダパス選択
' 引数：str_タイトル
'****
Private Function 取得_フォルダパス(ByVal str_タイトル As String) As String
    Dim obj_ダイアログ As FileDialog
    Set obj_ダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
    With obj_ダイアログ
        .Title = str_タイトル
        .AllowMultiSelect = False
        If .Show = -1 Then
            取得_フォルダパス = .SelectedItems(1)
        Else
            取得_フォルダパス = ""
        End If
    End With
End Function

'****
' プロシージャー概要：対象ファイル一覧取得
' 引数：str_フォルダ, str_拡張子セミコロン区切り
' 戻り値：Collection（ファイル名）
'****
Private Function 取得_対象ファイル一覧(ByVal str_フォルダ As String, ByVal str_拡張子セミコロン区切り As String) As Collection
    Dim col_結果 As New Collection
    Dim arr_拡張子() As String: arr_拡張子 = Split(str_拡張子セミコロン区切り, ";")
    Dim lng_i As Long
    For lng_i = LBound(arr_拡張子) To UBound(arr_拡張子)
        Dim str_パターン As String: str_パターン = arr_拡張子(lng_i)
        Dim str_名 As String: str_名 = Dir(str_フォルダ & "\" & str_パターン)
        Do While Len(str_名) > 0
            If Left$(str_名, 2) <> "~$" Then col_結果.Add str_名
            str_名 = Dir()
        Loop
    Next lng_i
    Set 取得_対象ファイル一覧 = col_結果
End Function

'****
' プロシージャー概要：シート名の存在確認
' 引数：wb_対象, str_シート名
'****
Private Function シート存在有無(ByVal wb_対象 As Workbook, ByVal str_シート名 As String) As Boolean
    Dim ws_探査 As Worksheet
    On Error Resume Next
    Set ws_探査 = wb_対象.Worksheets(str_シート名)
    シート存在有無 = Not ws_探査 Is Nothing
    On Error GoTo 0
End Function

'****
' プロシージャー概要：日付文字列の正規化
' 引数：var_値, bool_ok(ByRef)
' 戻り値：Double（CDbl(DateSerial(...))）
'****
Private Function 解析_日付シリアル(ByVal var_値 As Variant, ByRef bool_ok As Boolean) As Double
    On Error GoTo FAIL
    bool_ok = False

    If IsDate(var_値) Then
        解析_日付シリアル = CDbl(CDate(var_値))
        bool_ok = True
        Exit Function
    End If

    Dim str_s As String: str_s = Trim$(CStr(var_値))
    If Len(str_s) = 0 Then GoTo FAIL

    str_s = Replace(str_s, "-", "/")
    str_s = Replace(str_s, ".", "/")

    Dim arr_parts() As String
    arr_parts = Split(str_s, "/")
    If UBound(arr_parts) <> 2 Then GoTo FAIL
    If Not (IsNumeric(arr_parts(0)) And IsNumeric(arr_parts(1)) And IsNumeric(arr_parts(2))) Then GoTo FAIL

    Dim lng_y As Long, lng_m As Long, lng_d As Long
    If Len(arr_parts(0)) = 4 Then
        lng_y = CLng(arr_parts(0)): lng_m = CLng(arr_parts(1)): lng_d = CLng(arr_parts(2))
    ElseIf Len(arr_parts(2)) = 4 Then
        lng_y = CLng(arr_parts(2)): lng_m = CLng(arr_parts(1)): lng_d = CLng(arr_parts(0))
    Else
        GoTo FAIL
    End If

    解析_日付シリアル = CDbl(DateSerial(lng_y, lng_m, lng_d))
    bool_ok = True
    Exit Function

FAIL:
    bool_ok = False
    解析_日付シリアル = 0#
End Function