LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@Ko813(葉坪 忍田)

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

Last updated at Posted at 2025-10-15

改良ポイント

・シートの中のボタンとモジュールを1ペアとして書き直しました。

・設定項目をエクセルシートから変更可能に

モジュール1


Option Explicit
'==========================================================
' モジュール名：mod_UI_Create
' 機能概要　　：DiffUIシートの作成およびボタン生成を行う
'==========================================================

'----------------------------------------------------------
' run_作成_UIシート
' 機能概要 : DiffUIシートを新規作成し、見出し・オプション列・ボタンを配置する
' 引数　　: なし
' 戻り値　: なし
'----------------------------------------------------------
Public Sub run_作成_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("A5").Resize(1, 5).Value = Array("ファイル", "シート", "セル", "列見出し", "不一致理由")
        .Rows(5).Font.Bold = True
        .Columns("A:E").AutoFit
    End With

    '=== オプション設定列（G列～） ===
    With ws_UI
        .Cells(1, 7).Value = "許容誤差": .Cells(2, 7).Value = 0.000001
        .Cells(1, 8).Value = "大文字小文字区別": .Cells(2, 8).Value = "FALSE"
        .Cells(1, 9).Value = "TRIM比較": .Cells(2, 9).Value = "TRUE"
        .Cells(1, 10).Value = "拡張子パターン": .Cells(2, 10).Value = "*.xlsx;*.xlsm"
        .Cells(1, 11).Value = "日付同値扱い": .Cells(2, 11).Value = "FALSE"
        .Cells(1, 12).Value = "書式差分検出": .Cells(2, 12).Value = "FALSE"
        .Cells(1, 13).Value = "シート名で比較": .Cells(2, 13).Value = "TRUE"
        .Range("G1:M1").Font.Bold = True
        .Columns("G:M").AutoFit
    End With

    '=== ボタン生成 ===
    call_追加_ボタン図形 ws_UI, "btnRef1", "参照1（基準フォルダ）", 20, 34, 160, 24, "run_RefFolder1_Click"
    call_追加_ボタン図形 ws_UI, "btnRef2", "参照2（比較フォルダ）", 190, 34, 160, 24, "run_RefFolder2_Click"
    call_追加_ボタン図形 ws_UI, "btnDiff", "比較実行（全ファイル×全シート）", 360, 34, 230, 24, "run_DiffFolders_Click"

    MsgBox "UIシートを作成しました。フォルダを選択して比較を開始できます。", vbInformation
End Sub


'----------------------------------------------------------
' call_追加_ボタン図形
' 機能概要 : 指定位置に角丸ボタン図形を作成し、マクロを割り当てる
' 引数　　: ws_対象（Worksheet）  … ボタンを追加するシート
'           str_名前（String）      … ボタン名
'           str_表示名（String）    … 表示テキスト
'           sng_Left/Top/Width/Height（Single）… 位置とサイズ
'           str_マクロ名（String）  … 割当マクロ名
' 戻り値　: なし
'----------------------------------------------------------
Private Sub call_追加_ボタン図形( _
        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

モジュール2


Option Explicit
'==========================================================
' モジュール名：mod_UI_FolderSelect
' 機能概要　　：基準／比較フォルダのパスを参照ダイアログで選択
'==========================================================

'----------------------------------------------------------
' run_RefFolder1_Click
' 機能概要 : 基準フォルダのパスを選択し、B2セルに反映する
' 引数　　: なし
' 戻り値　: なし
'----------------------------------------------------------
Public Sub run_RefFolder1_Click()
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_パス As String
    str_パス = get_フォルダパス("基準フォルダを選択してください")
    If Len(str_パス) > 0 Then ws_UI.Range("B2").Value = str_パス
End Sub


'----------------------------------------------------------
' run_RefFolder2_Click
' 機能概要 : 比較フォルダのパスを選択し、B3セルに反映する
' 引数　　: なし
' 戻り値　: なし
'----------------------------------------------------------
Public Sub run_RefFolder2_Click()
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")
    Dim str_パス As String
    str_パス = get_フォルダパス("比較フォルダを選択してください")
    If Len(str_パス) > 0 Then ws_UI.Range("B3").Value = str_パス
End Sub


'----------------------------------------------------------
' get_フォルダパス
' 機能概要 : フォルダ選択ダイアログを表示し、選択されたパスを返す
' 引数　　: str_タイトル（String） … ダイアログのタイトル
' 戻り値　: String（選択フォルダパス／未選択時は空文字）
'----------------------------------------------------------
Private Function get_フォルダパス(ByVal str_タイトル As String) As String
    Dim fd_ダイアログ As FileDialog
    Set fd_ダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
    With fd_ダイアログ
        .Title = str_タイトル
        .AllowMultiSelect = False
        If .Show = -1 Then
            get_フォルダパス = .SelectedItems(1)
        Else
            get_フォルダパス = ""
        End If
    End With
End Function

モジュール3


Option Explicit
'==========================================================
' モジュール名：mod_UI_RunCompare
' 機能概要　　：基準／比較フォルダ内の同名Excelブックを全シート比較し結果を出力
'==========================================================

'==== モジュール変数（DiffUIオプション列から読み取る）====
Private dbl_許容誤差 As Double
Private bool_大文字小文字区別 As Boolean
Private bool_TRIM比較 As Boolean
Private str_拡張子パターン As String
Private bool_日付同値扱い As Boolean
Private bool_書式差分検出 As Boolean
Private bool_シート名で比較 As Boolean

'----------------------------------------------------------
' run_DiffFolders_Click
' 機能概要 : DiffUI上の比較実行ボタン押下時に全比較処理を実行する
' 引数　　: なし
' 戻り値　: なし
'----------------------------------------------------------
Public Sub run_DiffFolders_Click()
    On Error GoTo ERR_HANDLER
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")

    '=== オプション読込 ===
    call_読込_ユーザー設定 ws_UI

    '=== フォルダ確認 ===
    Dim str_基準Dir As String: str_基準Dir = Trim$(ws_UI.Range("B2").Value)
    Dim str_比較Dir As String: str_比較Dir = Trim$(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

    '=== ファイル一覧取得 ===
    Dim col_ファイル一覧 As Collection
    Set col_ファイル一覧 = get_対象ファイル一覧(str_基準Dir, str_拡張子パターン)
    If col_ファイル一覧 Is Nothing Or col_ファイル一覧.Count = 0 Then
        ws_UI.Range("A6").Value = "基準フォルダに対象ブックが見つかりません。"
        Exit Sub
    End If

    '=== 比較結果出力 ===
    Dim lng_出力行 As Long: lng_出力行 = 6
    Dim lng_差分数 As Long
    Dim var_ファイル名 As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    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_出力行, 5).Value = "比較側に同名ファイルなし"
            lng_出力行 = lng_出力行 + 1
            GoTo NEXT_FILE
        End If

        '=== 同名ファイル開けない対策（比較側コピー） ===
        Dim str_比較一時 As String
        str_比較一時 = get_比較側一時コピーパス(str_比較パス)

        Dim wb_基準 As Workbook, wb_比較 As Workbook
        Set wb_基準 = Workbooks.Open(str_基準パス, ReadOnly:=True)
        Set wb_比較 = Workbooks.Open(str_比較一時, ReadOnly:=True)

        Dim col_差分 As Collection
        Set col_差分 = get_全シート差分(wb_基準, wb_比較)

        '=== 差分出力 ===
        If 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_差分
                ws_UI.Cells(lng_出力行, 1).Value = var_行(0)
                ws_UI.Cells(lng_出力行, 2).Value = var_行(1)
                ws_UI.Cells(lng_出力行, 3).Value = var_行(2)
                ws_UI.Cells(lng_出力行, 4).Value = var_行(3)
                ws_UI.Cells(lng_出力行, 5).Value = var_行(4)
                lng_出力行 = lng_出力行 + 1
                lng_差分数 = lng_差分数 + 1
            Next var_行
        End If

        wb_基準.Close False
        wb_比較.Close False
        call_削除_一時ファイル安全(str_比較一時)
NEXT_FILE:
    Next var_ファイル名

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "比較が完了しました。差分：" & lng_差分数 & " 件", vbInformation
    Exit Sub

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


'----------------------------------------------------------
' call_読込_ユーザー設定
' 機能概要 : DiffUIシートのオプション設定列から変数を読み込む
' 引数　　: ws_UI（Worksheet） … DiffUIシート
' 戻り値　: なし
'----------------------------------------------------------
Private Sub call_読込_ユーザー設定(ByVal ws_UI As Worksheet)
    Dim rng_ヘッダ As Range, rng_値 As Range
    Set rng_ヘッダ = ws_UI.Rows(1)
    Set rng_値 = ws_UI.Rows(2)

    Dim lng_列 As Long
    For lng_列 = 7 To ws_UI.Cells(1, ws_UI.Columns.Count).End(xlToLeft).Column
        Dim str_項目 As String
        str_項目 = LCase$(Trim$(CStr(rng_ヘッダ.Cells(1, lng_列).Value)))
        Select Case str_項目
            Case "許容誤差": dbl_許容誤差 = Val(rng_値.Cells(1, lng_列).Value)
            Case "大文字小文字区別": bool_大文字小文字区別 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "trim比較": bool_TRIM比較 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "拡張子パターン": str_拡張子パターン = CStr(rng_値.Cells(1, lng_列).Value)
            Case "日付同値扱い": bool_日付同値扱い = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "書式差分検出": bool_書式差分検出 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "シート名で比較": bool_シート名で比較 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
        End Select
    Next lng_列

    If dbl_許容誤差 <= 0 Then dbl_許容誤差 = 0.000001
    If Len(str_拡張子パターン) = 0 Then str_拡張子パターン = "*.xlsx;*.xlsm"
End Sub


'----------------------------------------------------------
' is_真偽
' 機能概要 : TRUE/FALSEを文字列・数値から評価して返す
' 引数　　: var_値（Variant）
' 戻り値　: Boolean
'----------------------------------------------------------
Private Function is_真偽(ByVal var_値 As Variant) As Boolean
    Dim str_値 As String: str_値 = LCase$(Trim$(CStr(var_値)))
    is_真偽 = (str_値 = "true" Or str_値 = "t" Or str_値 = "1" Or str_値 = "yes" Or str_値 = "y" Or str_値 = "on")
End Function


'----------------------------------------------------------
' get_対象ファイル一覧
' 機能概要 : 指定フォルダ内で拡張子一致するファイル名リストを返す
' 引数　　: str_フォルダ（String） … 対象フォルダパス
'             str_拡張（String）　 … "*.xlsx;*.xlsm" のような形式
' 戻り値　: Collection（ファイル名一覧）
'----------------------------------------------------------
Private Function get_対象ファイル一覧(ByVal str_フォルダ As String, ByVal str_拡張 As String) As Collection
    Dim col_結果 As New Collection
    Dim arr_拡張() As String, lng_i As Long
    arr_拡張 = Split(str_拡張, ";")

    Dim str_ファイル As String
    For lng_i = LBound(arr_拡張) To UBound(arr_拡張)
        str_ファイル = Dir(str_フォルダ & "\" & Trim$(arr_拡張(lng_i)))
        Do While str_ファイル <> ""
            If Left$(str_ファイル, 2) <> "~$" Then col_結果.Add str_ファイル
            str_ファイル = Dir()
        Loop
    Next lng_i
    Set get_対象ファイル一覧 = col_結果
End Function


'----------------------------------------------------------
' get_比較側一時コピーパス
' 機能概要 : 同名ブックが開けない問題を回避するため、一時コピーを作成
' 引数　　: str_元（String） … コピー元ファイルパス
' 戻り値　: String（一時コピー先パス／失敗時は元パス）
'----------------------------------------------------------
Private Function get_比較側一時コピーパス(ByVal str_元 As String) As String
    On Error GoTo ERR_HANDLER
    Dim str_ファイル名 As String, str_拡張 As String, str_一時 As String
    str_ファイル名 = Mid$(str_元, InStrRev(str_元, "\") + 1)
    str_拡張 = Mid$(str_ファイル名, InStrRev(str_ファイル名, "."))
    str_一時 = Environ$("TEMP") & "\" & Left$(str_ファイル名, Len(str_ファイル名) - Len(str_拡張)) & "_tmp" & str_拡張
    FileCopy str_元, str_一時
    get_比較側一時コピーパス = str_一時
    Exit Function
ERR_HANDLER:
    get_比較側一時コピーパス = str_元
End Function


'----------------------------------------------------------
' call_削除_一時ファイル安全
' 機能概要 : TEMPフォルダに存在する一時ファイルを安全に削除
' 引数　　: str_パス（String）
' 戻り値　: なし
'----------------------------------------------------------
Private Sub call_削除_一時ファイル安全(ByVal str_パス As String)
    On Error Resume Next
    If InStr(1, str_パス, Environ$("TEMP"), vbTextCompare) > 0 Then
        If Dir(str_パス) <> "" Then Kill str_パス
    End If
    On Error GoTo 0
End Sub


'----------------------------------------------------------
' get_全シート差分
' 機能概要 : 2ブック内の全シートを比較して差分結果を返す
' 引数　　: wb_基準 / wb_比較（Workbook）
' 戻り値　: Collection（差分情報）
'----------------------------------------------------------
Private Function get_全シート差分(ByVal wb_基準 As Workbook, ByVal wb_比較 As Workbook) As Collection
    Dim col_結果 As New Collection
    Dim ws_基準 As Worksheet, ws_比較 As Worksheet

    If bool_シート名で比較 Then
        For Each ws_基準 In wb_基準.Worksheets
            On Error Resume Next
            Set ws_比較 = wb_比較.Worksheets(ws_基準.Name)
            On Error GoTo 0

            If ws_比較 Is Nothing Then
                col_結果.Add Array("＜基準＞", ws_基準.Name, "", "", "シート過不足：比較側に存在しません")
            Else
                call_追加_シート比較 col_結果, ws_基準, ws_比較
            End If
            Set ws_比較 = Nothing
        Next ws_基準

        For Each ws_比較 In wb_比較.Worksheets
            If Not is_シート存在(wb_基準, ws_比較.Name) Then
                col_結果.Add Array("＜比較＞", ws_比較.Name, "", "", "シート過不足：基準側に存在しません")
            End If
        Next ws_比較
    Else
        Dim lng_i As Long, lng_最大 As Long
        lng_最大 = Application.Min(wb_基準.Worksheets.Count, wb_比較.Worksheets.Count)
        For lng_i = 1 To lng_最大
            call_追加_シート比較 col_結果, wb_基準.Worksheets(lng_i), wb_比較.Worksheets(lng_i)
        Next lng_i
    End If

    Set get_全シート差分 = col_結果
End Function


'----------------------------------------------------------
' call_追加_シート比較
' 機能概要 : シート単位で全セルを比較し、差分をコレクションに追加
' 引数　　: col_出力（Collection） … 差分格納先
'             ws_基準 / ws_比較（Worksheet）
' 戻り値　: なし
'----------------------------------------------------------
Private Sub call_追加_シート比較(ByRef col_出力 As Collection, ByVal ws_基準 As Worksheet, ByVal ws_比較 As Worksheet)
    Dim lng_最終行 As Long, lng_最終列 As Long
    lng_最終行 = Application.Max(ws_基準.UsedRange.Rows.Count, ws_比較.UsedRange.Rows.Count)
    lng_最終列 = Application.Max(ws_基準.UsedRange.Columns.Count, ws_比較.UsedRange.Columns.Count)

    Dim lng_行 As Long, lng_列 As Long
    For lng_行 = 1 To lng_最終行
        For lng_列 = 1 To lng_最終列
            Dim var_左値 As Variant, var_右値 As Variant
            var_左値 = ws_基準.Cells(lng_行, lng_列).Value
            var_右値 = ws_比較.Cells(lng_行, lng_列).Value

            If Not is_値等しい(var_左値, var_右値) Then
                col_出力.Add Array("＜基準⇔比較＞", ws_基準.Name, ws_基準.Cells(lng_行, lng_列).Address(False, False), _
                                   ws_基準.Cells(1, lng_列).Value, _
                                   "値不一致（左:" & var_左値 & "／右:" & var_右値 & "）")
            End If
        Next lng_列
    Next lng_行
End Sub


'----------------------------------------------------------
' is_値等しい
' 機能概要 : 数値・文字・日付を考慮して2値を比較
' 引数　　: var_A / var_B（Variant）
' 戻り値　: Boolean（等しい=True）
'----------------------------------------------------------
Private Function is_値等しい(ByVal var_A As Variant, ByVal var_B As Variant) As Boolean
    If IsNumeric(var_A) And IsNumeric(var_B) Then
        is_値等しい = (Abs(CDbl(var_A) - CDbl(var_B)) <= dbl_許容誤差)
    ElseIf IsDate(var_A) And IsDate(var_B) And bool_日付同値扱い Then
        is_値等しい = (Abs(CDbl(CDate(var_A)) - CDbl(CDate(var_B))) < 0.0000001)
    Else
        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
        is_値等しい = (str_A = str_B)
    End If
End Function


'----------------------------------------------------------
' is_シート存在
' 機能概要 : 指定ブック内にシート名が存在するか判定
' 引数　　: wb_対象（Workbook）
'             str_シート名（String）
' 戻り値　: Boolean（存在=True）
'----------------------------------------------------------
Private Function is_シート存在(ByVal wb_対象

書き直し版です。

Option Explicit
'==========================================================
' モジュール名：mod_UI_RunCompare
' 機能概要　　：基準／比較フォルダ内の同名Excelブックを全シート比較し結果を出力
'==========================================================

'==== モジュール変数（DiffUIオプション列から読み取る）====
Private dbl_許容誤差 As Double
Private bool_大文字小文字区別 As Boolean
Private bool_TRIM比較 As Boolean
Private str_拡張子パターン As String
Private bool_日付同値扱い As Boolean
Private bool_書式差分検出 As Boolean
Private bool_シート名で比較 As Boolean

'----------------------------------------------------------
' run_DiffFolders_Click
' 機能概要 : DiffUI上の比較実行ボタン押下時に全比較処理を実行する
' 引数　　: なし
' 戻り値　: なし
'----------------------------------------------------------
Public Sub run_DiffFolders_Click()
    On Error GoTo ERR_HANDLER
    Dim ws_UI As Worksheet: Set ws_UI = Worksheets("DiffUI")

    '=== オプション読込 ===
    call_読込_ユーザー設定 ws_UI

    '=== フォルダ確認 ===
    Dim str_基準Dir As String: str_基準Dir = Trim$(ws_UI.Range("B2").Value)
    Dim str_比較Dir As String: str_比較Dir = Trim$(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

    '=== ファイル一覧取得 ===
    Dim col_ファイル一覧 As Collection
    Set col_ファイル一覧 = get_対象ファイル一覧(str_基準Dir, str_拡張子パターン)
    If col_ファイル一覧 Is Nothing Or col_ファイル一覧.Count = 0 Then
        ws_UI.Range("A6").Value = "基準フォルダに対象ブックが見つかりません。"
        Exit Sub
    End If

    '=== 比較結果出力 ===
    Dim lng_出力行 As Long: lng_出力行 = 6
    Dim lng_差分数 As Long
    Dim var_ファイル名 As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    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_出力行, 5).Value = "比較側に同名ファイルなし"
            lng_出力行 = lng_出力行 + 1
            GoTo NEXT_FILE
        End If

        '=== 同名ファイル開けない対策（比較側コピー） ===
        Dim str_比較一時 As String
        str_比較一時 = get_比較側一時コピーパス(str_比較パス)

        Dim wb_基準 As Workbook, wb_比較 As Workbook
        Set wb_基準 = Workbooks.Open(str_基準パス, ReadOnly:=True)
        Set wb_比較 = Workbooks.Open(str_比較一時, ReadOnly:=True)

        Dim col_差分 As Collection
        Set col_差分 = get_全シート差分(wb_基準, wb_比較)

        '=== 差分出力 ===
        If 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_差分
                ws_UI.Cells(lng_出力行, 1).Value = var_行(0)
                ws_UI.Cells(lng_出力行, 2).Value = var_行(1)
                ws_UI.Cells(lng_出力行, 3).Value = var_行(2)
                ws_UI.Cells(lng_出力行, 4).Value = var_行(3)
                ws_UI.Cells(lng_出力行, 5).Value = var_行(4)
                lng_出力行 = lng_出力行 + 1
                lng_差分数 = lng_差分数 + 1
            Next var_行
        End If

        wb_基準.Close False
        wb_比較.Close False
        call_削除_一時ファイル安全 str_比較一時
NEXT_FILE:
    Next var_ファイル名

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "比較が完了しました。差分：" & lng_差分数 & " 件", vbInformation
    Exit Sub
ERR_HANDLER:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ws_UI.Range("A6").Value = "エラー: " & Err.Number & " / " & Err.Description
End Sub

'----------------------------------------------------------
' call_読込_ユーザー設定
' 機能概要 : DiffUIシートのオプション設定列から変数を読み込む
' 引数　　: ws_UI（Worksheet） … DiffUIシート
' 戻り値　: なし
'----------------------------------------------------------
Private Sub call_読込_ユーザー設定(ByVal ws_UI As Worksheet)
    Dim rng_ヘッダ As Range, rng_値 As Range
    Set rng_ヘッダ = ws_UI.Rows(1)
    Set rng_値 = ws_UI.Rows(2)

    Dim lng_列 As Long
    For lng_列 = 7 To ws_UI.Cells(1, ws_UI.Columns.Count).End(xlToLeft).Column
        Dim str_項目 As String
        str_項目 = LCase$(Trim$(CStr(rng_ヘッダ.Cells(1, lng_列).Value)))
        Select Case str_項目
            Case "許容誤差": dbl_許容誤差 = Val(rng_値.Cells(1, lng_列).Value)
            Case "大文字小文字区別": bool_大文字小文字区別 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "trim比較": bool_TRIM比較 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "拡張子パターン": str_拡張子パターン = CStr(rng_値.Cells(1, lng_列).Value)
            Case "日付同値扱い": bool_日付同値扱い = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "書式差分検出": bool_書式差分検出 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
            Case "シート名で比較": bool_シート名で比較 = CBool(is_真偽(rng_値.Cells(1, lng_列).Value))
        End Select
    Next lng_列

    If dbl_許容誤差 <= 0 Then dbl_許容誤差 = 0.000001
    If Len(str_拡張子パターン) = 0 Then str_拡張子パターン = "*.xlsx;*.xlsm"
End Sub

'----------------------------------------------------------
' is_真偽
' 機能概要 : TRUE/FALSEを文字列・数値から評価して返す
' 引数　　: var_値（Variant）
' 戻り値　: Boolean
'----------------------------------------------------------
Private Function is_真偽(ByVal var_値 As Variant) As Boolean
    Dim str_値 As String: str_値 = LCase$(Trim$(CStr(var_値)))
    is_真偽 = (str_値 = "true" Or str_値 = "t" Or str_値 = "1" Or str_値 = "yes" Or str_値 = "y" Or str_値 = "on")
End Function

'----------------------------------------------------------
' get_対象ファイル一覧
' 機能概要 : 指定フォルダ内で拡張子一致するファイル名リストを返す
' 引数　　: str_フォルダ（String） … 対象フォルダパス
'             str_拡張（String）　 … "*.xlsx;*.xlsm" のような形式
' 戻り値　: Collection（ファイル名一覧）
'----------------------------------------------------------
Private Function get_対象ファイル一覧(ByVal str_フォルダ As String, ByVal str_拡張 As String) As Collection
    Dim col_結果 As New Collection
    Dim arr_拡張() As String, lng_i As Long
    arr_拡張 = Split(str_拡張, ";")

    Dim str_ファイル As String
    For lng_i = LBound(arr_拡張) To UBound(arr_拡張)
        str_ファイル = Dir(str_フォルダ & "\" & Trim$(arr_拡張(lng_i)))
        Do While str_ファイル <> ""
            If Left$(str_ファイル, 2) <> "~$" Then col_結果.Add str_ファイル
            str_ファイル = Dir()
        Loop
    Next lng_i
    Set get_対象ファイル一覧 = col_結果
End Function

'----------------------------------------------------------
' get_比較側一時コピーパス
' 機能概要 : 同名ブックが開けない問題を回避するため、一時コピーを作成
' 引数　　: str_元（String） … コピー元ファイルパス
' 戻り値　: String（一時コピー先パス／失敗時は元パス）
'----------------------------------------------------------
Private Function get_比較側一時コピーパス(ByVal str_元 As String) As String
    On Error GoTo ERR_HANDLER
    Dim str_ファイル名 As String, str_拡張 As String, str_一時 As String
    str_ファイル名 = Mid$(str_元, InStrRev(str_元, "\") + 1)
    str_拡張 = Mid$(str_ファイル名, InStrRev(str_ファイル名, "."))
    str_一時 = Environ$("TEMP") & "\" & Left$(str_ファイル名, Len(str_ファイル名) - Len(str_拡張)) & "_tmp" & str_拡張
    FileCopy str_元, str_一時
    get_比較側一時コピーパス = str_一時
    Exit Function
ERR_HANDLER:
    get_比較側一時コピーパス = str_元
End Function

'----------------------------------------------------------
' call_削除_一時ファイル安全
' 機能概要 : TEMPフォルダに存在する一時ファイルを安全に削除
' 引数　　: str_パス（String）
' 戻り値　: なし
'----------------------------------------------------------
Private Sub call_削除_一時ファイル安全(ByVal str_パス As String)
    On Error Resume Next
    If InStr(1, str_パス, Environ$("TEMP"), vbTextCompare) > 0 Then
        If Dir(str_パス) <> "" Then Kill str_パス
    End If
    On Error GoTo 0
End Sub

'----------------------------------------------------------
' get_全シート差分
' 機能概要 : 2ブック内の全シートを比較して差分結果を返す
' 引数　　: wb_基準 / wb_比較（Workbook）
' 戻り値　: Collection（差分情報）
'----------------------------------------------------------
Private Function get_全シート差分(ByVal wb_基準 As Workbook, ByVal wb_比較 As Workbook) As Collection
    Dim col_結果 As New Collection
    Dim ws_基準 As Worksheet, ws_比較 As Worksheet

    If bool_シート名で比較 Then
        For Each ws_基準 In wb_基準.Worksheets
            On Error Resume Next
            Set ws_比較 = wb_比較.Worksheets(ws_基準.Name)
            On Error GoTo 0

            If ws_比較 Is Nothing Then
                col_結果.Add Array("＜基準＞", ws_基準.Name, "", "", "シート過不足：比較側に存在しません")
            Else
                call_追加_シート比較 col_結果, ws_基準, ws_比較
            End If
            Set ws_比較 = Nothing
        Next ws_基準

        For Each ws_比較 In wb_比較.Worksheets
            ' is_シート存在 のような関数は存在しないため、直接参照を試みるロジックに変更
            On Error Resume Next
            Set ws_基準 = wb_基準.Worksheets(ws_比較.Name)
            On Error GoTo 0
            If ws_基準 Is Nothing Then
                col_結果.Add Array("＜比較＞", ws_比較.Name, "", "", "シート過不足：基準側に存在しません")
            End If
            Set ws_基準 = Nothing
        Next ws_比較
    Else
        Dim lng_i As Long, lng_最大 As Long
        lng_最大 = Application.Min(wb_基準.Worksheets.Count, wb_比較.Worksheets.Count)
        For lng_i = 1 To lng_最大
            call_追加_シート比較 col_結果, wb_基準.Worksheets(lng_i), wb_比較.Worksheets(lng_i)
        Next lng_i
    End If

    Set get_全シート差分 = col_結果
End Function

'----------------------------------------------------------
' call_追加_シート比較
' 機能概要 : シート単位で全セルを比較し、差分をコレクションに追加
' 引数　　: col_出力（Collection） … 差分格納先
'             ws_基準 / ws_比較（Worksheet）
' 戻り値　: なし
'----------------------------------------------------------
' ＜修正前＞
'Private Sub call_追加_シート比較(ByRef col_出力 As Collection, ByVal ws_基準 As Worksheet, ByVal ws_比較 As Worksheet)
'    Dim lng_最終行 As Long, lng_最終列 As Long
'    lng_最終行 = Application.Max(ws_基準.UsedRange.Rows.Count, ws_比較.UsedRange.Rows.Count)
'    lng_最終列 = Application.Max(ws_基準.UsedRange.Columns.Count, ws_比較.UsedRange.Columns.Count)
'
'    Dim lng_行 As Long, lng_列 As Long
'    For lng_行 = 1 To lng_最終行
'        For lng_列 = 1 To lng_最終列
'            Dim var_左値 As Variant, var_右値 As Variant
'            var_左値 = ws_基準.Cells(lng_行, lng_列).Value
'            var_右値 = ws_比較.Cells(lng_行, lng_列).Value
'
'            If Not is_値等しい(var_左値, var_右値) Then
'                col_出力.Add Array("＜基準⇔比較＞", ws_基準.Name, ws_基準.Cells(lng_行, lng_列).Address(False, False), _
'                                   ws_基準.Cells(1, lng_列).Value, _
'                                   "値不一致（左:" & var_左値 & "／右:" & var_右値 & "）")
'            End If
'        Next lng_列
'    Next lng_行
'End Sub
' ＜修正後＞
Private Sub call_追加_シート比較(ByRef col_出力 As Collection, ByVal ws_基準 As Worksheet, ByVal ws_比較 As Worksheet)
    Dim lng_最終行 As Long, lng_最終列 As Long
    lng_最終行 = Application.Max(ws_基準.UsedRange.Rows.Count, ws_比較.UsedRange.Rows.Count)
    lng_最終列 = Application.Max(ws_基準.UsedRange.Columns.Count, ws_比較.UsedRange.Columns.Count)

    Dim lng_行 As Long, lng_列 As Long
    For lng_行 = 1 To lng_最終行
        For lng_列 = 1 To lng_最終列
            ' --- 基準セルと比較セルをオブジェクトとして取得 ---
            Dim rng_基準 As Range: Set rng_基準 = ws_基準.Cells(lng_行, lng_列)
            Dim rng_比較 As Range: Set rng_比較 = ws_比較.Cells(lng_行, lng_列)

            Dim var_左値 As Variant, var_右値 As Variant
            var_左値 = rng_基準.Value
            var_右値 = rng_比較.Value

            ' === 値の比較 ===
            If Not is_値等しい(var_左値, var_右値) Then
                col_出力.Add Array("＜基準⇔比較＞", ws_基準.Name, rng_基準.Address(False, False), _
                                   ws_基準.Cells(1, lng_列).Value, _
                                   "値不一致（基準:" & CStr(var_左値) & "／比較:" & CStr(var_右値) & "）")
            End If

            ' ＜新規追加＞
            ' === 書式の比較（オプションがTrueの場合のみ実行） ===
            If bool_書式差分検出 Then
                Dim str_差分理由 As String
                str_差分理由 = ""

                ' 背景色
                If rng_基準.Interior.Color <> rng_比較.Interior.Color Then
                    str_差分理由 = str_差分理由 & "背景色, "
                End If

                ' フォント色
                If rng_基準.Font.Color <> rng_比較.Font.Color Then
                    str_差分理由 = str_差分理由 & "文字色, "
                End If

                ' 太字
                If rng_基準.Font.Bold <> rng_比較.Font.Bold Then
                    str_差分理由 = str_差分理由 & "太字, "
                End If

                ' 表示形式
                If rng_基準.NumberFormatLocal <> rng_比較.NumberFormatLocal Then
                    str_差分理由 = str_差分理由 & "表示形式, "
                End If

                ' 差分があれば結果コレクションに追加
                If Len(str_差分理由) > 0 Then
                    ' 末尾の ", " を削除
                    str_差分理由 = Left$(str_差分理由, Len(str_差分理由) - 2)
                    col_出力.Add Array("＜基準⇔比較＞", ws_基準.Name, rng_基準.Address(False, False), _
                                       ws_基準.Cells(1, lng_列).Value, _
                                       "書式不一致（" & str_差分理由 & "）")
                End If
            End If
            ' ＜／新規追加＞
        Next lng_列
    Next lng_行
End Sub


'----------------------------------------------------------
' is_値等しい
' 機能概要 : 数値・文字・日付を考慮して2値を比較
' 引数　　: var_A / var_B（Variant）
' 戻り値　: Boolean（等しい=True）
'----------------------------------------------------------
' ＜修正前＞
'Private Function is_値等しい(ByVal var_A As Variant, ByVal var_B As Variant) As Boolean
'    If IsNumeric(var_A) And IsNumeric(var_B) Then
'        is_値等しい = (Abs(CDbl(var_A) - CDbl(var_B)) <= dbl_許容誤差)
'    ElseIf IsDate(var_A) And IsDate(var_B) And bool_日付同値扱い Then
'        is_値等しい = (Abs(CDbl(CDate(var_A)) - CDbl(CDate(var_B))) < 0.0000001)
'    Else
'        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
'        is_値等しい = (str_A = str_B)
'    End If
'End Function
' ＜修正後＞
Private Function is_値等しい(ByVal var_A As Variant, ByVal var_B As Variant) As Boolean
    ' --- 評価順序の変更：日付 → 数値 → 文字列 ---
    ' 1. 日付として比較 (日付同値扱いがTRUEの場合)
    If bool_日付同値扱い And IsDate(var_A) And IsDate(var_B) Then
        ' 日付はシリアル値の差で比較。時刻も含むため許容誤差は極小値で判定
        is_値等しい = (Abs(CDbl(CDate(var_A)) - CDbl(CDate(var_B))) < 0.0000001)

    ' 2. 数値として比較 (日付でないことが前提)
    ElseIf IsNumeric(var_A) And IsNumeric(var_B) Then
        ' 許容誤差を考慮
        is_値等しい = (Abs(CDbl(var_A) - CDbl(var_B)) <= dbl_許容誤差)

    ' 3. 文字列として比較
    Else
        Dim str_A As String, str_B As String
        str_A = CStr(var_A): str_B = CStr(var_B)

        ' TRIM比較オプション
        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

        is_値等しい = (str_A = str_B)
    End If
End Function
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?