Excel VBA 逆引き集 | 差分レポート自動生成

Excel VBA
スポンサーリンク

差分レポート自動生成

「前月Aと今月Bの差分を“新規・削除・変更”に分けて、見やすいレポートを自動で作る」ためのテンプレです。初心者でも壊れないコツは「キーの正規化」「見出し名で列特定」「配列＋辞書で抽出」「フォーマット整形」「必要ならPDF出力」。

ゴールと基本設計

  • 出力ゴール:
    • 新規（Bのみ）, 削除（Aのみ）, 変更（項目別差分）をそれぞれシートで一覧化
    • サマリー（件数・金額の合計など）を1枚に集約
    • 見やすい整形（太字・オートフィット・色分け）
    • 必要ならPDFで保存
  • 設計の柱:
    • キーは Trim＋UCase で正規化
    • 見出し名から列位置を取る（列順変更に強い）
    • 配列→辞書→一括貼付で高速化
    • 数値は Val→CDbl、日付は yyyy-mm に統一

下準備ユーティリティ（速度・安全・見出し）

Option Explicit

Private Sub SpeedOn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function

Private Function NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function
VB
  • ポイント
    • SpeedOn/Off: 無駄な再描画・再計算を止めて高速安定。
    • EnsureSheet: 何度でも安全に出力シートを用意。
    • FindHeader: 見出し名で列を特定し、列順変動に強く。
    • NormKey: Trim＋UCase で表記揺れを吸収。

差分レポートの自動生成（単一キー・名称/単価の例）

AとBから新規・削除・変更を作り、サマリーも自動生成します。

Sub GenerateDiffReport()
    SpeedOn

    '入力：A (前月), B (今月)
    Dim rgA As Range: Set rgA = Worksheets("A").Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = Worksheets("B").Range("A1").CurrentRegion
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    '見出し（キー＋比較項目）
    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    Dim cNameA As Long: cNameA = FindHeader(rgA.Rows(1), "名称")
    Dim cNameB As Long: cNameB = FindHeader(rgB.Rows(1), "名称")
    Dim cPriceA As Long: cPriceA = FindHeader(rgA.Rows(1), "単価")
    Dim cPriceB As Long: cPriceB = FindHeader(rgB.Rows(1), "単価")
    If cKeyA*cKeyB*cNameA*cNameB*cPriceA*cPriceB = 0 Then SpeedOff: MsgBox "見出し不足（コード/名称/単価）": Exit Sub

    'B辞書（キー→(名称,単価)）
    Dim dB As Object: Set dB = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cKeyB))
        If Len(k) > 0 Then dB(k) = Array(CStr(vB(i, cNameB)), CDbl(Val(vB(i, cPriceB))))
    Next

    'Aキー集合
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKeyA))
        If Len(k) > 0 Then setA(k) = True
    Next

    '出力シート
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規(Bのみ)", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除(Aのみ)", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(項目差分)", True)
    Dim wsSum As Worksheet: Set wsSum = EnsureSheet("差分サマリー", True)

    wsNew.Range("A1:D1").Value = Array("コード", "名称(B)", "単価(B)", "備考")
    wsDel.Range("A1:D1").Value = Array("コード", "名称(A)", "単価(A)", "備考")
    wsChg.Range("A1:E1").Value = Array("コード", "項目", "A値", "B値", "差分")

    Dim rNew As Long: rNew = 2
    Dim rDel As Long: rDel = 2
    Dim rChg As Long: rChg = 2

    'A基準で削除・変更を確定
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKeyA))
        If Len(k) = 0 Then GoTo nextA

        Dim aName As String: aName = CStr(vA(i, cNameA))
        Dim aPrice As Double: aPrice = CDbl(Val(vA(i, cPriceA)))

        If dB.Exists(k) Then
            Dim bName As String: bName = dB(k)(0)
            Dim bPrice As Double: bPrice = dB(k)(1)

            If aName <> bName Then
                wsChg.Cells(rChg, 1).Value = vA(i, cKeyA)
                wsChg.Cells(rChg, 2).Value = "名称"
                wsChg.Cells(rChg, 3).Value = aName
                wsChg.Cells(rChg, 4).Value = bName
                wsChg.Cells(rChg, 5).Value = "変更"
                rChg = rChg + 1
            End If
            If aPrice <> bPrice Then
                wsChg.Cells(rChg, 1).Value = vA(i, cKeyA)
                wsChg.Cells(rChg, 2).Value = "単価"
                wsChg.Cells(rChg, 3).Value = aPrice
                wsChg.Cells(rChg, 4).Value = bPrice
                wsChg.Cells(rChg, 5).Value = bPrice - aPrice
                rChg = rChg + 1
            End If
        Else
            wsDel.Cells(rDel, 1).Value = vA(i, cKeyA)
            wsDel.Cells(rDel, 2).Value = aName
            wsDel.Cells(rDel, 3).Value = aPrice
            wsDel.Cells(rDel, 4).Value = "Aのみ"
            rDel = rDel + 1
        End If
nextA:
    Next

    'Bのみ（新規）
    Dim j As Long
    For j = 2 To UBound(vB, 1)
        k = NormKey(vB(j, cKeyB))
        If Len(k) > 0 And Not setA.Exists(k) Then
            wsNew.Cells(rNew, 1).Value = vB(j, cKeyB)
            wsNew.Cells(rNew, 2).Value = vB(j, cNameB)
            wsNew.Cells(rNew, 3).Value = vB(j, cPriceB)
            wsNew.Cells(rNew, 4).Value = "Bのみ"
            rNew = rNew + 1
        End If
    Next

    'サマリー（件数・金額合計の例）
    wsSum.Range("A1:B1").Value = Array("項目", "値")
    wsSum.Range("A2:B6").Value = Array( _
        Array("新規件数", rNew - 2), _
        Array("削除件数", rDel - 2), _
        Array("変更行数", rChg - 2), _
        Array("新規単価合計", WorksheetFunction.Sum(wsNew.Range("C2:C" & rNew - 1))), _
        Array("削除単価合計", WorksheetFunction.Sum(wsDel.Range("C2:C" & rDel - 1))) _
    )

    '見やすさ整形
    Dim arrWs As Variant: arrWs = Array(wsNew, wsDel, wsChg, wsSum)
    Dim x As Variant
    For Each x In arrWs
        x.Rows(1).Font.Bold = True
        x.Columns.AutoFit
    Next

    SpeedOff
End Sub
VB
  • ポイント
    • 3分類＋サマリー一括生成: 件数や金額の合計も同時に作ると配布が楽。
    • 差分列（変更の差額）: 単価など数値は差分も出して可視化。

比較項目を増減できる柔軟テンプレ（見出し指定）

項目見出しの配列を渡せば、差分の対象を増減できます。数値項目は数値比較、文字項目は文字比較に自動切り替え。

Sub GenerateDiffReport_Flexible()
    SpeedOn

    Dim rgA As Range: Set rgA = Worksheets("A").Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = Worksheets("B").Range("A1").CurrentRegion
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    If cKeyA = 0 Or cKeyB = 0 Then SpeedOff: MsgBox "キー見出し不足": Exit Sub

    '比較項目の見出し名（増減OK）
    Dim fields As Variant: fields = Array("名称", "カテゴリ", "単価", "ステータス")

    '列マップ
    Dim i As Long
    Dim mapA() As Long: ReDim mapA(LBound(fields) To UBound(fields))
    Dim mapB() As Long: ReDim mapB(LBound(fields) To UBound(fields))
    For i = LBound(fields) To UBound(fields)
        mapA(i) = FindHeader(rgA.Rows(1), fields(i))
        mapB(i) = FindHeader(rgB.Rows(1), fields(i))
        If mapA(i) = 0 Or mapB(i) = 0 Then SpeedOff: MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    'B辞書（キー→行番号）
    Dim mapBRow As Object: Set mapBRow = CreateObject("Scripting.Dictionary")
    Dim r As Long, k As String
    For r = 2 To UBound(vB, 1)
        k = NormKey(vB(r, cKeyB))
        If Len(k) > 0 Then mapBRow(k) = r
    Next

    '出力
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(柔軟項目)", True)
    wsChg.Range("A1:E1").Value = Array("コード", "項目", "A値", "B値", "差分(数値のみ)")

    Dim rOut As Long: rOut = 2
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Or Not mapBRow.Exists(k) Then GoTo contA
        Dim rb As Long: rb = mapBRow(k)

        For i = LBound(fields) To UBound(fields)
            Dim va As Variant: va = vA(r, mapA(i))
            Dim vb As Variant: vb = vB(rb, mapB(i))
            Dim isNum As Boolean: isNum = (fields(i) Like "*単価*" Or fields(i) Like "*金額*")
            Dim diff As Boolean
            If isNum Then
                diff = (CDbl(Val(va)) <> CDbl(Val(vb)))
            Else
                diff = (CStr(va) <> CStr(vb))
            End If
            If diff Then
                wsChg.Cells(rOut, 1).Value = vA(r, cKeyA)
                wsChg.Cells(rOut, 2).Value = fields(i)
                wsChg.Cells(rOut, 3).Value = va
                wsChg.Cells(rOut, 4).Value = vb
                wsChg.Cells(rOut, 5).Value = IIf(isNum, CDbl(Val(vb)) - CDbl(Val(va)), "")
                rOut = rOut + 1
            End If
        Next
contA:
    Next

    wsChg.Rows(1).Font.Bold = True
    wsChg.Columns.AutoFit
    SpeedOff
End Sub
VB
  • ポイント
    • 柔軟性: 比較対象の見出しを変えても壊れない。
    • 数値差分のみ数値計算: 誤判定や書式依存を避ける。

複合キー（コード×年月）差分レポート

年月でバージョンが変わる場合に。複合キーを作って3分類＋サマリーを生成。

Private Function BuildKey2(ByVal code As Variant, ByVal ymd As Variant) As String
    Dim ym As String
    If IsDate(ymd) Then ym = Format$(CDate(ymd), "yyyy-mm") Else ym = CStr(ymd)
    BuildKey2 = NormKey(code) & "|" & UCase$(Trim$(ym))
End Function

Sub GenerateDiffReport_MultiKey()
    SpeedOn

    'A/B列想定：A=コード, B=年月, C=名称, D=単価
    Dim vA As Variant: vA = Worksheets("A").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("B").Range("A1").CurrentRegion.Value

    'B辞書（複合キー→(名称,単価)）
    Dim dB As Object: Set dB = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vB, 1)
        key = BuildKey2(vB(i, 1), vB(i, 2))
        dB(key) = Array(CStr(vB(i, 3)), CDbl(Val(vB(i, 4))))
    Next

    'Aキー集合
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        setA(BuildKey2(vA(i, 1), vA(i, 2))) = True
    Next

    '出力
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規_複合", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除_複合", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更_複合", True)
    Dim wsSum As Worksheet: Set wsSum = EnsureSheet("差分サマリー_複合", True)

    wsNew.Range("A1:E1").Value = Array("コード", "年月", "名称(B)", "単価(B)", "備考")
    wsDel.Range("A1:E1").Value = Array("コード", "年月", "名称(A)", "単価(A)", "備考")
    wsChg.Range("A1:F1").Value = Array("コード|年月", "項目", "A値", "B値", "差分", "備考")

    Dim rNew As Long: rNew = 2
    Dim rDel As Long: rDel = 2
    Dim rChg As Long: rChg = 2

    For i = 2 To UBound(vA, 1)
        key = BuildKey2(vA(i, 1), vA(i, 2))
        Dim aName As String: aName = CStr(vA(i, 3))
        Dim aPrice As Double: aPrice = CDbl(Val(vA(i, 4)))

        If dB.Exists(key) Then
            Dim bName As String: bName = dB(key)(0)
            Dim bPrice As Double: bPrice = dB(key)(1)
            If aName <> bName Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = "名称"
                wsChg.Cells(rChg, 3).Value = aName
                wsChg.Cells(rChg, 4).Value = bName
                wsChg.Cells(rChg, 5).Value = ""
                wsChg.Cells(rChg, 6).Value = "変更"
                rChg = rChg + 1
            End If
            If aPrice <> bPrice Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = "単価"
                wsChg.Cells(rChg, 3).Value = aPrice
                wsChg.Cells(rChg, 4).Value = bPrice
                wsChg.Cells(rChg, 5).Value = bPrice - aPrice
                wsChg.Cells(rChg, 6).Value = "変更"
                rChg = rChg + 1
            End If
        Else
            wsDel.Cells(rDel, 1).Value = vA(i, 1)
            wsDel.Cells(rDel, 2).Value = IIf(IsDate(vA(i, 2)), Format$(CDate(vA(i, 2)), "yyyy-mm"), vA(i, 2))
            wsDel.Cells(rDel, 3).Value = aName
            wsDel.Cells(rDel, 4).Value = aPrice
            wsDel.Cells(rDel, 5).Value = "Aのみ"
            rDel = rDel + 1
        End If
    Next

    Dim j As Long
    For j = 2 To UBound(vB, 1)
        key = BuildKey2(vB(j, 1), vB(j, 2))
        If Not setA.Exists(key) Then
            wsNew.Cells(rNew, 1).Value = vB(j, 1)
            wsNew.Cells(rNew, 2).Value = IIf(IsDate(vB(j, 2)), Format$(CDate(vB(j, 2)), "yyyy-mm"), vB(j, 2))
            wsNew.Cells(rNew, 3).Value = vB(j, 3)
            wsNew.Cells(rNew, 4).Value = vB(j, 4)
            wsNew.Cells(rNew, 5).Value = "Bのみ"
            rNew = rNew + 1
        End If
    Next

    wsSum.Range("A1:B1").Value = Array("項目", "値")
    wsSum.Range("A2:B6").Value = Array( _
        Array("新規件数", rNew - 2), _
        Array("削除件数", rDel - 2), _
        Array("変更行数", rChg - 2), _
        Array("新規単価合計", WorksheetFunction.Sum(wsNew.Range("D2:D" & rNew - 1))), _
        Array("削除単価合計", WorksheetFunction.Sum(wsDel.Range("D2:D" & rDel - 1))) _
    )

    Dim arrWs As Variant: arrWs = Array(wsNew, wsDel, wsChg, wsSum)
    Dim x As Variant
    For Each x In arrWs
        x.Rows(1).Font.Bold = True
        x.Columns.AutoFit
    Next

    SpeedOff
End Sub
VB
  • ポイント
    • 年月統一: yyyy-mm 固定で揺れを防ぐ。
    • 複合キー文字連結: 区切りは「|」が安全。

レポート配布の仕上げ（PDF保存・色分け・並び替え）

必要に応じて、レポートをPDFで保存します。

Sub SaveDiffSummaryAsPDF()
    Dim ws As Worksheet: Set ws = Worksheets("差分サマリー")
    Dim path As String: path = ThisWorkbook.Path & "\差分サマリー.pdf"
    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=path
    MsgBox "PDF保存完了: " & path
End Sub
VB
  • 見やすさの小ワザ
    • 色分け: 新規＝淡緑、削除＝淡赤、変更＝黄色で塗ると直感的。
    • 並び替え: コード昇順や変更項目優先で並べ替えると確認が早い。

よくある落とし穴と対策

  • キー表記揺れで誤分類（新規/削除に化ける）
    • 対策: NormKey（Trim＋UCase）を両側に徹底。必要なら半角化・記号除去も。
  • 数値・日付の型ズレで誤判定
    • 対策: 数値は Val→CDbl、日付は IsDate→Format(“yyyy-mm”) で統一。
  • 列順変更で壊れる
    • 対策: FindHeaderで見出しから列位置を特定。足りない場合は早期停止。
  • 大量行で遅い
    • 対策: すべて配列・辞書・一括貼付。処理前後で SpeedOn/Off。

例題で練習

'例1：単一キーで差分レポート＋サマリー
Sub Example_DiffBasicReport()
    GenerateDiffReport
End Sub

'例2：見出し名で柔軟に項目を指定して差分レポート
Sub Example_DiffFlexibleReport()
    GenerateDiffReport_Flexible
End Sub

'例3：複合キー（コード×年月）で差分レポート＋サマリー
Sub Example_DiffMultiKeyReport()
    GenerateDiffReport_MultiKey
End Sub

'例4：差分サマリーをPDFで保存
Sub Example_SaveDiffPDF()
    SaveDiffSummaryAsPDF
End Sub
VB

スポンサーリンク
タイトルとURLをコピーしました