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(葉坪 忍田)

Excel VBAで「_前」と「_後」を一括比較：TRUE/FALSEマップ＋数式差分リスト＋集計を自動生成する

Last updated at Posted at 2025-09-04

Excel VBAで「_前」と「_後」を一括比較：TRUE/FALSEマップ＋数式差分リスト＋集計を自動生成する

背景

Excelで台帳（シート）を運用していると、旧版（前）と新版（後）で**「中身の数式が変わっていないか」**を確認したい場面がよくあります。
目視チェックは漏れやすく、関数が多いシートでは現実的ではありません。

そこで、シート名が _前 / _後 で対になっているものを自動検出し、以下を自動生成するVBAを作りました。

  • TRUE/FALSEマップ：前!A1 = 後!A1 を全セルに展開して比較（TRUE/ FALSE）
  • FALSEハイライト：FALSEセルを赤塗り＋件数を表示
  • 数式差分リスト：式のテキストの違い（片方のみ式含む/式文字列が異なる）を表で出力
  • 集計シート：シートごとの総セル数・TRUE/ FALSE件数・FALSE率・数式差分件数を一覧

ポイント：

  • 「結果が同じ（値一致）」の確認はTRUE/FALSEマップで、
  • 「数式自体の差分」は数式差分リストで、
    二段構えで漏れを防ぎます。

前提

  • 比較対象のシート名は <ベース名>_前 と <ベース名>_後 のペア。例：売上台帳_前 と 売上台帳_後
  • フォーマット（行列範囲）は同じ前提（最終行・最終列は双方の最大を採用）

できること

  1. すべての <ベース名>_前 を走査し、対となる <ベース名>_後 を自動検出
  2. <ベース名>_比較 シートを作成し、全セルに = 前!rc = 後!rc を式として配置（文字列化させないために .Formula を使用＋NumberFormat="General"）
  3. FALSEセルを赤塗り＋件数メッセージ
  4. <ベース名>_差分 シートに 式テキストの差分のみ を一覧（セル番地 / 判定 / 旧式 / 新式 / 旧値 / 新値）
  5. 比較_集計 シートに各ベースのサマリを横並び出力

使い方

  1. 旧版シートを <ベース名>_前、新版シートを <ベース名>_後 に揃える（7シート程度まで想定）
  2. 下記コードを標準モジュールに貼り付け
  3. メイン_シート比較() を実行
    • 自動で「比較」「差分」「集計」が作られます
    • FALSEセルは赤塗りされ、件数がメッセージで出ます

実装（VBA）

Option Explicit

'========================
' 設定値
'========================
Private Const STR_接尾_前 As String = "_前"
Private Const STR_接尾_後 As String = "_後"
Private Const LNG_塗色_FALSE As Long = vbRed

'========================
' エントリーポイント（Publicはこれだけ）
'========================
Public Sub メイン_シート比較()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    On Error GoTo ERR_HANDLER
    
    Call 作成_比較と差分と集計_全シート
    
    MsgBox "比較・差分・集計の作成が完了しました。", vbInformation

FINALLY:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Exit Sub
ERR_HANDLER:
    MsgBox "エラー: " & Err.Description, vbExclamation
    Resume FINALLY
End Sub

'========================
' メイン処理（全シートを走査）
'========================
Private Sub 作成_比較と差分と集計_全シート()
    Dim ws As Worksheet
    Dim str_ベース名 As String
    Dim ws_前 As Worksheet, ws_後 As Worksheet
    Dim lng_総セル As Long, lng_FALSE As Long
    Dim lng_数式差分件数 As Long
    
    Call シート_削除_あれば("比較_集計")
    Dim ws_集計 As Worksheet
    Set ws_集計 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws_集計.Name = "比較_集計"
    With ws_集計
        .Range("A1:D1").Value = Array("ベース名", "総セル数", "FALSE数", "数式差分件数")
        .Rows(1).Font.Bold = True
    End With
    
    Dim lng_集計行 As Long: lng_集計行 = 2
    
    For Each ws In ThisWorkbook.Worksheets
        If 右が一致(ws.Name, STR_接尾_前) Then
            str_ベース名 = Left(ws.Name, Len(ws.Name) - Len(STR_接尾_前))
            
            Set ws_前 = ws
            Set ws_後 = シート_取得_存在時(str_ベース名 & STR_接尾_後)
            If ws_後 Is Nothing Then GoTo NEXT_WS
            
            ' 比較シートの作成（TRUE/FALSEマップ）
            Dim ws_比較 As Worksheet
            Set ws_比較 = 作成_比較シート(ws_前, ws_後, str_ベース名, lng_総セル)
            
            ' FALSEのハイライト＆件数取得
            lng_FALSE = ハイライト_FALSE_件数(ws_比較)
            
            ' 数式差分のリスト出力
            lng_数式差分件数 = 出力_数式差分リスト(ws_前, ws_後, str_ベース名)
            
            ' 集計出力（FALSE率は出さない）
            ws_集計.Cells(lng_集計行, 1).Resize(1, 4).Value = _
                Array(str_ベース名, lng_総セル, lng_FALSE, lng_数式差分件数)
            lng_集計行 = lng_集計行 + 1
        End If
NEXT_WS:
        Set ws_後 = Nothing
    Next ws
    
    ws_集計.Columns.AutoFit
End Sub

'========================
' TRUE/FALSEマップ（比較シート）作成
'========================
Private Function 作成_比較シート(ByVal ws_前 As Worksheet, _
                               ByVal ws_後 As Worksheet, _
                               ByVal str_ベース名 As String, _
                               ByRef lng_総セル As Long) As Worksheet
    Dim str_比較名 As String: str_比較名 = str_ベース名 & "_比較"
    Call シート_削除_あれば(str_比較名)
    
    Dim ws_比較 As Worksheet
    Set ws_比較 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws_比較.Name = str_比較名
    
    Dim lng_最終行 As Long, lng_最終列 As Long
    lng_最終行 = 最大値(最終行(ws_前), 最終行(ws_後))
    lng_最終列 = 最大値(最終列(ws_前), 最終列(ws_後))
    
    If lng_最終行 = 0 Or lng_最終列 = 0 Then
        lng_総セル = 0
        Set 作成_比較シート = ws_比較
        Exit Function
    End If
    
    Dim lng_r As Long, lng_c As Long
    Dim str_addr As String
    
    Application.StatusBar = "作成中: " & str_比較名
    
    For lng_r = 1 To lng_最終行
        For lng_c = 1 To lng_最終列
            str_addr = Cells(lng_r, lng_c).Address(False, False)
            With ws_比較.Cells(lng_r, lng_c)
                .Formula = "=" & _
                    "'" & ws_前.Name & "'!" & str_addr & " = " & _
                    "'" & ws_後.Name & "'!" & str_addr
                .NumberFormat = "General" ' 文字列化回避
            End With
        Next lng_c
    Next lng_r
    
    lng_総セル = CLng(lng_最終行) * CLng(lng_最終列)
    Set 作成_比較シート = ws_比較
End Function

'========================
' FALSEセルのハイライト＆件数
'========================
Private Function ハイライト_FALSE_件数(ByVal ws_比較 As Worksheet) As Long
    Dim rng_式 As Range, c As Range
    Dim lng_件数 As Long: lng_件数 = 0
    
    On Error Resume Next
    Set rng_式 = ws_比較.UsedRange.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If rng_式 Is Nothing Then
        ハイライト_FALSE_件数 = 0
        Exit Function
    End If
    
    For Each c In rng_式
        If VarType(c.Value) = vbBoolean Then
            If c.Value = False Then
                c.Interior.Color = LNG_塗色_FALSE
                lng_件数 = lng_件数 + 1
            End If
        End If
    Next c
    
    MsgBox ws_比較.Name & " のFALSEセル: " & lng_件数 & " 件", vbInformation
    ハイライト_FALSE_件数 = lng_件数
End Function

'========================
' 数式差分のリスト出力（式テキストの違い）
'========================
Private Function 出力_数式差分リスト(ByVal ws_前 As Worksheet, _
                                ByVal ws_後 As Worksheet, _
                                ByVal str_ベース名 As String) As Long
    Dim str_差分名 As String: str_差分名 = str_ベース名 & "_差分"
    Call シート_削除_あれば(str_差分名)
    
    Dim ws_差分 As Worksheet
    Set ws_差分 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws_差分.Name = str_差分名
    
    With ws_差分
        .Range("A1:F1").Value = Array("セル", "判定", "旧式", "新式", "旧値", "新値")
        .Rows(1).Font.Bold = True
    End With
    
    Dim lng_最終行 As Long, lng_最終列 As Long
    lng_最終行 = 最大値(最終行(ws_前), 最終行(ws_後))
    lng_最終列 = 最大値(最終列(ws_前), 最終列(ws_後))
    
    Dim lng_r As Long, lng_c As Long, lng_out As Long: lng_out = 2
    Dim hasF1 As Boolean, hasF2 As Boolean
    Dim f1 As String, f2 As String
    Dim v1 As Variant, v2 As Variant
    Dim addr As String, 判定 As String
    
    Application.StatusBar = "差分抽出: " & str_差分名
    
    For lng_r = 1 To lng_最終行
        For lng_c = 1 To lng_最終列
            addr = Cells(lng_r, lng_c).Address(False, False)
            hasF1 = ws_前.Cells(lng_r, lng_c).HasFormula
            hasF2 = ws_後.Cells(lng_r, lng_c).HasFormula
            f1 = IIf(hasF1, ws_前.Cells(lng_r, lng_c).Formula, "")
            f2 = IIf(hasF2, ws_後.Cells(lng_r, lng_c).Formula, "")
            
            If (hasF1 Xor hasF2) Or (hasF1 And hasF2 And f1 <> f2) Then
                v1 = ws_前.Cells(lng_r, lng_c).Value
                v2 = ws_後.Cells(lng_r, lng_c).Value
                判定 = IIf(v1 = v2, "値一致", "値不一致")
                
                ws_差分.Cells(lng_out, 1).Resize(1, 6).Value = _
                    Array(addr, 判定, f1, f2, v1, v2)
                lng_out = lng_out + 1
            End If
        Next lng_c
    Next lng_r
    
    ws_差分.Columns.AutoFit
    出力_数式差分リスト = lng_out - 2
End Function

'========================
' ユーティリティ
'========================
Private Function シート_取得_存在時(ByVal str_名前 As String) As Worksheet
    On Error Resume Next
    Set シート_取得_存在時 = ThisWorkbook.Worksheets(str_名前)
    On Error GoTo 0
End Function

Private Sub シート_削除_あれば(ByVal str_名前 As String)
    Dim ws As Worksheet
    Set ws = シート_取得_存在時(str_名前)
    If Not ws Is Nothing Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
End Sub

Private Function 右が一致(ByVal s As String, ByVal suffix As String) As Boolean
    If Len(s) < Len(suffix) Then
        右が一致 = False
    Else
        右が一致 = (Right$(s, Len(suffix)) = suffix)
    End If
End Function

Private Function 最終行(ByVal ws As Worksheet) As Long
    Dim r As Range
    On Error Resume Next
    Set r = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0
    If r Is Nothing Then
        最終行 = 0
    Else
        最終行 = r.Row
    End If
End Function

Private Function 最終列(ByVal ws As Worksheet) As Long
    Dim r As Range
    On Error Resume Next
    Set r = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
    On Error GoTo 0
    If r Is Nothing Then
        最終列 = 0
    Else
        最終列 = r.Column
    End If
End Function

Private Function 最大値(ByVal a As Long, ByVal b As Long) As Long
    If a >= b Then
        最大値 = a
    Else
        最大値 = b
    End If
End Function

実行結果のイメージ

  • <ベース名>_比較：TRUE/FALSEのグリッド（FALSEは赤塗り）
  • <ベース名>_差分：数式テキストの差分だけを一覧（セル / 旧式 / 新式 / 旧値 / 新値）
  • 比較_集計：各ベース名ごとの 総セル数 / FALSE数 / FALSE率 / 数式差分件数

よくある落とし穴と対策

  • 数式は同じだが結果だけ違う：_比較 でFALSE、_差分 には出ません（仕様通り）。原因は参照先や入力値の違い。
  • 式は違うが結果が同じ：_比較 はTRUE、_差分 に出ます（式差分検知）。
  • 文字列化で式が入らない：本コードは .Formula ＋ NumberFormat="General" を設定。手貼り時は先頭のシングルクォートに注意。
  • 最終行・最終列の判定：Find("*") で式も値も対象。双方の最大を使うため範囲漏れを防止。

まとめ

  • 値一致の網羅チェック（TRUE/FALSEマップ）と、式テキストの厳密差分（差分リスト）を分離することで、
    「どちらもOK（結果一致＋式一致）」「結果一致だが式が違う」「結果不一致」の区別が明確になります。
  • 7シート程度なら十分高速。再現性のあるエビデンスとして、そのまま配布・保存可能です。
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?