Excel VBA 逆引き集 | 月次差分

Excel VBA
スポンサーリンク

月次差分

「先月と今月のデータを比べて、新規・削除・変更を出したい」——月単位で差分を確認するテンプレです。初心者でも理解しやすいように、コード例をかみ砕いて説明します。

月次差分の考え方

  • 対象: 同じキー（例：コード）で「年月」を突合。
  • 3分類:
    • 新規: 今月にあって先月にない
    • 削除: 先月にあって今月にない
    • 変更: 両方にあるが項目値が違う
  • 年月の扱い: 日付列から Format(CDate(日付), "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 NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function

Private Function NormMonth(ByVal v As Variant) As String
    If IsDate(v) Then
        NormMonth = Format$(CDate(v), "yyyy-mm")
    Else
        NormMonth = CStr(v)
    End If
End Function

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
VB

基本テンプレ：月次差分レポート

「Data」シートに日付・コード・名称・単価がある前提で、指定2か月分を比較します。

Sub MonthlyDiff_Report()
    SpeedOn

    '対象月（セルや入力から取得でもOK）
    Dim monthPrev As String: monthPrev = "2025-11"
    Dim monthCurr As String: monthCurr = "2025-12"

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    '見出し列
    Dim cDate As Long: cDate = FindHeader(rg.Rows(1), "日付")
    Dim cCode As Long: cCode = FindHeader(rg.Rows(1), "コード")
    Dim cName As Long: cName = FindHeader(rg.Rows(1), "名称")
    Dim cPrice As Long: cPrice = FindHeader(rg.Rows(1), "単価")
    If cDate*cCode*cName*cPrice = 0 Then SpeedOff: MsgBox "見出し不足": Exit Sub

    '辞書（先月・今月）
    Dim dPrev As Object: Set dPrev = CreateObject("Scripting.Dictionary")
    Dim dCurr As Object: Set dCurr = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(v, 1)
        Dim m As String: m = NormMonth(v(i, cDate))
        k = NormKey(v(i, cCode))
        If Len(k) = 0 Then GoTo contRow
        If m = monthPrev Then
            dPrev(k) = Array(CStr(v(i, cName)), CDbl(Val(v(i, cPrice))))
        ElseIf m = monthCurr Then
            dCurr(k) = Array(CStr(v(i, cName)), CDbl(Val(v(i, cPrice))))
        End If
contRow:
    Next

    '出力シート
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規(" & monthCurr & ")", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除(" & monthPrev & ")", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(" & monthPrev & "→" & monthCurr & ")", True)

    wsNew.Range("A1:C1").Value = Array("コード", "名称(今月)", "単価(今月)")
    wsDel.Range("A1:C1").Value = Array("コード", "名称(先月)", "単価(先月)")
    wsChg.Range("A1:E1").Value = Array("コード", "項目", "先月", "今月", "差分")

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

    '削除・変更
    Dim key As Variant
    For Each key In dPrev.Keys
        If dCurr.Exists(key) Then
            Dim nP As String: nP = dPrev(key)(0)
            Dim pP As Double: pP = dPrev(key)(1)
            Dim nC As String: nC = dCurr(key)(0)
            Dim pC As Double: pC = dCurr(key)(1)
            If nP <> nC Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = "名称"
                wsChg.Cells(rChg, 3).Value = nP
                wsChg.Cells(rChg, 4).Value = nC
                rChg = rChg + 1
            End If
            If pP <> pC Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = "単価"
                wsChg.Cells(rChg, 3).Value = pP
                wsChg.Cells(rChg, 4).Value = pC
                wsChg.Cells(rChg, 5).Value = pC - pP
                rChg = rChg + 1
            End If
        Else
            wsDel.Cells(rDel, 1).Value = key
            wsDel.Cells(rDel, 2).Value = dPrev(key)(0)
            wsDel.Cells(rDel, 3).Value = dPrev(key)(1)
            rDel = rDel + 1
        End If
    Next

    '新規
    For Each key In dCurr.Keys
        If Not dPrev.Exists(key) Then
            wsNew.Cells(rNew, 1).Value = key
            wsNew.Cells(rNew, 2).Value = dCurr(key)(0)
            wsNew.Cells(rNew, 3).Value = dCurr(key)(1)
            rNew = rNew + 1
        End If
    Next

    wsNew.Columns.AutoFit: wsDel.Columns.AutoFit: wsChg.Columns.AutoFit

    SpeedOff
    MsgBox "月次差分: 新規=" & rNew - 2 & " 削除=" & rDel - 2 & " 変更=" & rChg - 2
End Sub
VB

例題で練習

'例1：先月と今月の差分レポート
Sub Example_MonthlyReport()
    MonthlyDiff_Report
End Sub
VB

初心者向けポイント

  • 年月統一: Format(CDate(日付), "yyyy-mm")で「2025/12/1」「2025-12」などを同じ扱いに。
  • 3分類: 新規・削除・変更を別シートに出すと確認が楽。
  • 差分列: 単価など数値は差分も出すと分析に便利。
  • 見出し名で列特定: 列順が変わっても壊れない。

実務の落とし穴と対策

  • 日付表記揺れで誤判定 → NormMonthで統一。
  • キー重複で混乱 → NormKeyでTrim＋UCase。
  • 大量行で遅い → 配列＋辞書＋SpeedOn/Offで高速化。
スポンサーリンク
タイトルとURLをコピーしました