エクセルブック出力結果比較ツール（エビデンス作成ツール）

Microsoft Excel｜ブック同士を = で比較して監査に強いエビデンスを自動生成するVBAツール（前回ブラッシュアップ）

UI自体も生成するので、
エディタか何かに保存しておいてすぐに組み立てられるようにしました。

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作成（最初に1回実行） ====
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

'==== 図形ボタン追加・マクロ割当 ====
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_Btn As Shape
    Set shp_Btn = ws_対象.Shapes.AddShape(msoShapeRoundedRectangle, sng_Left, sng_Top, sng_Width, sng_Height)
    With shp_Btn
        .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

'==== 比較実行（フォルダ内の同名ファイルを一括比較） ====
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

'==== 全シート差分（構造化出力） ====
' 返り値：Collection of Array(シート名, セル番地, 見出し, 理由)
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 i As Long, n1 As Long, n2 As Long, n As Long
        n1 = wb_基準.Worksheets.Count: n2 = wb_比較.Worksheets.Count
        n = IIf(n1 < n2, n1, n2)
        For i = 1 To n
            追加_1シート差分 col_結果, wb_基準.Worksheets(i), wb_比較.Worksheets(i)
        Next i
        If n1 <> n2 Then
            ' 過不足を理由に追加
            If n1 > n2 Then
                For i = n2 + 1 To n1
                    col_結果.Add Array(wb_基準.Worksheets(i).Name, "", "", "シートの過不足：基準側のみ存在")
                Next i
            Else
                For i = n1 + 1 To n2
                    col_結果.Add Array(wb_比較.Worksheets(i).Name, "", "", "シートの過不足：比較側のみ存在")
                Next i
            End If
        End If
    End If

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

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

'==== 1シート比較（構造化：セル番地/見出し/理由） ====
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_c As Long
    For lng_c = 1 To lng_最終列
        If 取得_値(ws_基準.Cells(1, lng_c)) <> 取得_値(ws_比較.Cells(1, lng_c)) Then
            col_出力.Add Array(ws_基準.Name, ws_基準.Cells(1, lng_c).Address(False, False), "ヘッダ", _
                "値不一致：1行目の見出し不一致（" & CStr(取得_値(ws_基準.Cells(1, lng_c))) & _
                " vs " & CStr(取得_値(ws_比較.Cells(1, lng_c))) & ")")
        End If
    Next lng_c

    ' 全体を配列に一括コピー（値）
    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_r As Long
    For lng_r = 2 To lng_最終行 ' 1行目はヘッダ
        For lng_c = 1 To lng_最終列
            Dim str_アドレス As String
            str_アドレス = ws_基準.Cells(lng_r, lng_c).Address(False, False)

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

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

'==== 不一致理由の判定 ====
' 戻り値："値不一致"/"関数不一致"/"書式不一致" を " / " で連結（該当なければ空文字）
Private Function 取得_不一致理由(ByVal ws1 As Worksheet, ByVal ws2 As Worksheet, _
                           ByVal r As Long, ByVal c As Long, _
                           ByRef v1 As Variant, ByRef v2 As Variant) As String
    On Error GoTo EH
    Dim reasons As String

    ' 1) 値の等価
    Dim eqVal As Boolean
    eqVal = 値_等しい(v1(r, c), v2(r, c))
    If Not eqVal Then
        reasons = 追加理由(reasons, "値不一致（左:" & 表示_値(v1(r, c)) & " / 右:" & 表示_値(v2(r, c)) & ")")
    End If

    ' 2) 関数（数式）不一致：表示値が一致でも、式が違えば検出
    Dim hasF1 As Boolean, hasF2 As Boolean
    hasF1 = ws1.Cells(r, c).HasFormula
    hasF2 = ws2.Cells(r, c).HasFormula
    If hasF1 Or hasF2 Then
        Dim f1 As String, f2 As String
        f1 = 安全Formula(ws1.Cells(r, c))
        f2 = 安全Formula(ws2.Cells(r, c))
        If (f1 <> f2) Then reasons = 追加理由(reasons, "関数不一致（左:" & f1 & " / 右:" & f2 & ")")
    End If

    ' 3) 書式不一致（データ型差 ＋ オプションで表示形式差）
    Dim fmtDetail As String
    fmtDetail = 取得_書式差異詳細(v1(r, c), v2(r, c), ws1.Cells(r, c), ws2.Cells(r, c))
    If Len(fmtDetail) > 0 Then
        reasons = 追加理由(reasons, "書式不一致（" & fmtDetail & ")")
    End If

    取得_不一致理由 = reasons
    Exit Function
EH:
    取得_不一致理由 = ""
End Function

Private Function 追加理由(ByVal base As String, ByVal addOne As String) As String
    If Len(base) = 0 Then
        追加理由 = addOne
    Else
        追加理由 = base & " / " & addOne
    End If
End Function

'==== 書式相違（データ型差＋NumberFormat差） ====
Private Function 書式相違あり(ByVal vA As Variant, ByVal vB As Variant, _
                       ByVal cA As Range, ByVal cB As Range) As Boolean
    Dim s As String
    s = 取得_書式差異詳細(vA, vB, cA, cB)
    書式相違あり = (Len(s) > 0)
End Function

'==== 等価判定（数値誤差・文字TRIM/大小無視＋日付同値オプション） ====
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

    ' 文字列比較（TRIM/大小無視設定）
    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

'==== 書式差分（数式安全取得） ====
Private Function 安全Formula(ByVal rng As Range) As String
    On Error GoTo EH
    安全Formula = CStr(rng.Formula)
    Exit Function
EH:
    安全Formula = ""
End Function

' 書式差異の詳細（型相違 + NumberFormatLocalの差（オプション））を返す
Private Function 取得_書式差異詳細(ByVal vA As Variant, ByVal vB As Variant, _
                             ByVal cA As Range, ByVal cB As Range) As String
    On Error GoTo EH
    Dim parts As Collection: Set parts = New Collection

    ' 型（概念）差：数値/文字列/日付 を中心に
    Dim tA As String, tB As String
    tA = 型_記述(vA, cA)
    tB = 型_記述(vB, cB)
    If tA <> tB Then parts.Add ("型:" & tA & " vs " & tB)

    ' 表示形式差（オプション）
    If BOOL_書式差分検出 Then
        Dim nfA As String, nfB As String
        nfA = 安全NF(cA): nfB = 安全NF(cB)
        If nfA <> nfB Then parts.Add ("表示形式:" & nfA & " vs " & nfB)
    End If

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

' 型の日本語ラベル化（数値/日付/文字列/その他）
Private Function 型_記述(ByVal v As Variant, ByVal c As Range) As String
    On Error GoTo EH
    If IsNumeric(v) Then 型_記述 = "数値": Exit Function
    If IsDate(v) Then 型_記述 = "日付": Exit Function
    ' 文字列判定：空 or 非数値かつ非日付
    If VarType(v) = vbString Or LenB(v) > 0 Then 型_記述 = "文字列": Exit Function
    型_記述 = "その他"
    Exit Function
EH:
    型_記述 = "その他"
End Function

' 表示用：Variantを短く安全に文字列化
Private Function 表示_値(ByVal v As Variant) As String
    On Error GoTo EH
    Dim s As String
    s = CStr(v)
    If Len(s) > 64 Then s = Left$(s, 61) & "..."
    表示_値 = s
    Exit Function
EH:
    表示_値 = ""
End Function

' NumberFormatLocal を安全に取得（例外時は空文字）
Private Function 安全NF(ByVal rng As Range) As String
    On Error GoTo EH
    安全NF = CStr(rng.NumberFormatLocal)
    Exit Function
EH:
    安全NF = ""
End Function

'==== UsedRangeベースの最終行/最終列 ====
Private Function 最終行(ByVal ws_対象 As Worksheet) As Long
    With ws_対象.UsedRange
        最終行 = .Row + .Rows.Count - 1
    End With
End Function

Private Function 最終列(ByVal ws_対象 As Worksheet) As Long
    With ws_対象.UsedRange
        最終列 = .Column + .Columns.Count - 1
    End With
End Function

'==== セル値取得（Value2で高速・日付の自動変換なし） ====
Private Function 取得_値(ByVal rng_セル As Range) As Variant
    On Error GoTo EH
    取得_値 = rng_セル.Value2
    Exit Function
EH:
    取得_値 = Empty
End Function

'==== 一時コピー（同名ブック対策）＆削除 ====
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

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

'==== 汎用：ファイルダイアログ（フォルダ） ====
Private Function 取得_フォルダパス(ByVal str_タイトル As String) As String
    Dim obj_Dlg As FileDialog
    Set obj_Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    With obj_Dlg
        .Title = str_タイトル
        .AllowMultiSelect = False
        If .Show = -1 Then
            取得_フォルダパス = .SelectedItems(1)
        Else
            取得_フォルダパス = ""
        End If
    End With
End Function

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

'==== シート存在確認 ====
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

'==== 日付正規化（yyyy/mm/dd と dd/mm/yyyy のゆれを同値化） ====
' 戻り値：成功時は CDbl(DateSerial(...))、失敗時は 0 を返し bool_ok=False
Private Function 解析_日付シリアル(ByVal v As Variant, ByRef bool_ok As Boolean) As Double
    On Error GoTo FAIL
    bool_ok = False

    ' 既にIsDateで取れるもの（シリアル/日付型）はそのまま採用
    If IsDate(v) Then
        解析_日付シリアル = CDbl(CDate(v))
        bool_ok = True
        Exit Function
    End If

    Dim s As String: s = Trim$(CStr(v))
    If Len(s) = 0 Then GoTo FAIL

    ' 区切りを統一
    s = Replace(s, "-", "/")
    s = Replace(s, ".", "/")

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

    Dim y As Long, m As Long, d As Long
    ' パターン1：yyyy/mm/dd（先頭4桁が年）
    If Len(parts(0)) = 4 Then
        y = CLng(parts(0)): m = CLng(parts(1)): d = CLng(parts(2))
    ' パターン2：dd/mm/yyyy（末尾4桁が年）
    ElseIf Len(parts(2)) = 4 Then
        y = CLng(parts(2)): m = CLng(parts(1)): d = CLng(parts(0))
    Else
        GoTo FAIL
    End If

    ' 妥当性は DateSerial に委ねる（不正値はエラー→FAIL）
    解析_日付シリアル = CDbl(DateSerial(y, m, d))
    bool_ok = True
    Exit Function

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