Excel VBA 逆引き集 | 変更箇所だけ転記

Excel VBA
スポンサーリンク

変更箇所だけ転記

「前月Aと今月Bを比べて、変更されたところ“だけ”をAへ反映したい」「差分セルだけを別シートへ転記したい」——初心者でも壊れないテンプレを用意しました。ポイントは「キー突合」「数値/日付の型統一」「セル単位の転記」「監査しやすいログ出力」です。

共通ユーティリティ（速度・安全）

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
VB
  • 速度: 画面/イベント/計算停止でムダを削って安定。
  • キー正規化: Trim＋UCaseで表記揺れを吸収。

基本テンプレ：Bの変更セルだけAへ上書き（コードキー）

「A: コード/名称/単価」「B: コード/名称/単価」を突合し、違うセルだけAへ反映します。

Sub PatchDiff_Cells_ByKey()
    SpeedOn

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

    '列想定：1=コード, 2=名称, 3=単価（見出しあり）
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, 1))
        If Len(k) > 0 Then dictB(k) = i
    Next

    '変更ログ（任意）：別シートに残す
    Dim wsLog As Worksheet
    On Error Resume Next: Set wsLog = Worksheets("変更転記ログ"): On Error GoTo 0
    If wsLog Is Nothing Then Set wsLog = Worksheets.Add: wsLog.Name = "変更転記ログ"
    wsLog.Cells.Clear
    wsLog.Range("A1:D1").Value = Array("コード", "項目", "旧(A)", "新(B)")
    Dim rLog As Long: rLog = 2

    'Aへセル単位で反映
    Dim r As Long, rowA As Long, rowB As Long
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, 1))
        If Len(k) = 0 Or Not dictB.Exists(k) Then GoTo contA
        rowA = rgA.Row + r - 1
        rowB = rgB.Row + dictB(k) - 1

        '名称（文字）
        If CStr(vA(r, 2)) <> CStr(vB(dictB(k), 2)) Then
            wsA.Cells(rowA, rgA.Column + 1).Value = vB(dictB(k), 2)
            wsLog.Cells(rLog, 1).Value = vA(r, 1)
            wsLog.Cells(rLog, 2).Value = "名称"
            wsLog.Cells(rLog, 3).Value = vA(r, 2)
            wsLog.Cells(rLog, 4).Value = vB(dictB(k), 2)
            rLog = rLog + 1
        End If
        '単価（数値）
        Dim aPrice As Double: aPrice = CDbl(Val(vA(r, 3)))
        Dim bPrice As Double: bPrice = CDbl(Val(vB(dictB(k), 3)))
        If aPrice <> bPrice Then
            wsA.Cells(rowA, rgA.Column + 2).Value = bPrice
            wsLog.Cells(rLog, 1).Value = vA(r, 1)
            wsLog.Cells(rLog, 2).Value = "単価"
            wsLog.Cells(rLog, 3).Value = aPrice
            wsLog.Cells(rLog, 4).Value = bPrice
            rLog = rLog + 1
        End If
contA:
    Next

    wsLog.Rows(1).Font.Bold = True
    wsLog.Columns.AutoFit

    SpeedOff
End Sub
VB
  • ポイント
    • 変更セルだけを上書きするので安全（未一致キーは触らない）。
    • 数値は Val→CDblで比較・転記、書式は後で整える。

見出し名で柔軟対応（項目増やしても壊れない）

比較・転記対象を見出し名で指定。増減に強く、数値項目は数値比較で上書き。

Sub PatchDiff_Cells_ByHeaders()
    SpeedOn

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

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

    '比較・転記項目（見出し名配列）
    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) = FindCol(rgA, fields(i))
        mapB(i) = FindCol(rgB, fields(i))
        If mapA(i) = 0 Or mapB(i) = 0 Then SpeedOff: MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    'B辞書（キー→行番号）
    Dim dictB As Object: Set dictB = 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 dictB(k) = r
    Next

    'ログ
    Dim wsLog As Worksheet: Set wsLog = EnsureSheet("変更転記ログ", True)
    wsLog.Range("A1:D1").Value = Array("コード", "項目", "旧(A)", "新(B)")
    Dim rLog As Long: rLog = 2

    'Aへセル単位で反映
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Or Not dictB.Exists(k) Then GoTo contA
        Dim rb As Long: rb = dictB(k)
        Dim rowA As Long: rowA = rgA.Row + r - 1

        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 "*金額*" Or fields(i) Like "*在庫*")

            Dim diff As Boolean
            If isNum Then
                diff = (CDbl(Val(va)) <> CDbl(Val(vb)))
            ElseIf IsDate(va) Or IsDate(vb) Then
                diff = (Format$(CDate(va), "yyyy-mm-dd") <> Format$(CDate(vb), "yyyy-mm-dd"))
            Else
                diff = (CStr(va) <> CStr(vb))
            End If

            If diff Then
                wsA.Cells(rowA, mapA(i)).Value = vb
                wsLog.Cells(rLog, 1).Value = vA(r, cKeyA)
                wsLog.Cells(rLog, 2).Value = fields(i)
                wsLog.Cells(rLog, 3).Value = va
                wsLog.Cells(rLog, 4).Value = vb
                rLog = rLog + 1
            End If
        Next
contA:
    Next

    wsLog.Rows(1).Font.Bold = True
    wsLog.Columns.AutoFit

    SpeedOff
End Sub

Private Function FindCol(ByVal rg As Range, ByVal headerName As String) As Long
    Dim hit As Range
    Set hit = rg.Rows(1).Find(What:=headerName, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindCol = IIf(hit Is Nothing, 0, hit.Column)
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
VB
  • ポイント
    • 項目の増減に対応。数値/日付/文字で比較方法を自動切替。
    • 見出し名から列を取得して壊れにくい。

変更セルだけを別シートへ転記（監査・配布用）

Aは触らず、差分セルを「コード・項目・旧・新・A行・B行」で一覧化します。

Sub ExportDiffCells_ToSheet()
    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 = FindCol(rgA, "コード")
    Dim cKeyB As Long: cKeyB = FindCol(rgB, "コード")
    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) = FindCol(rgA, fields(i))
        mapB(i) = FindCol(rgB, fields(i))
        If mapA(i) = 0 Or mapB(i) = 0 Then SpeedOff: MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    Dim dictB As Object: Set dictB = 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 dictB(k) = r
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("変更セル一覧", True)
    wsOut.Range("A1:F1").Value = Array("コード", "項目", "旧(A)", "新(B)", "A行", "B行")
    Dim w As Long: w = 2

    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Or Not dictB.Exists(k) Then GoTo contA
        Dim rb As Long: rb = dictB(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 diff As Boolean
            If fields(i) Like "*単価*" Or fields(i) Like "*在庫*" Or fields(i) Like "*金額*" Then
                diff = (CDbl(Val(va)) <> CDbl(Val(vb)))
            Else
                diff = (CStr(va) <> CStr(vb))
            End If

            If diff Then
                wsOut.Cells(w, 1).Value = vA(r, cKeyA)
                wsOut.Cells(w, 2).Value = fields(i)
                wsOut.Cells(w, 3).Value = va
                wsOut.Cells(w, 4).Value = vb
                wsOut.Cells(w, 5).Value = rgA.Row + r - 1
                wsOut.Cells(w, 6).Value = rgB.Row + rb - 1
                w = w + 1
            End If
        Next
contA:
    Next

    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit

    SpeedOff
End Sub
VB
  • ポイント
    • 影響範囲の確認やレビューに便利。後から“必要なセルだけ”反映も可。

複合キー（コード×年月）で変更箇所だけ転記

年月単位で上書きしたいときは複合キー文字連結で突合。

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 PatchDiff_Cells_MultiKey()
    SpeedOn

    '列想定：A=コード, B=年月, C=名称, D=単価
    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

    'B辞書（複合キー→行）
    Dim dictB As Object: Set dictB = 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))
        dictB(key) = i
    Next

    'ログ
    Dim wsLog As Worksheet: Set wsLog = EnsureSheet("変更転記ログ_複合", True)
    wsLog.Range("A1:E1").Value = Array("コード|年月", "項目", "旧(A)", "新(B)", "A行")
    Dim w As Long: w = 2

    '反映
    Dim r As Long
    For r = 2 To UBound(vA, 1)
        key = BuildKey2(vA(r, 1), vA(r, 2))
        If Not dictB.Exists(key) Then GoTo contA
        Dim rb As Long: rb = dictB(key)
        Dim rowA As Long: rowA = rgA.Row + r - 1

        '名称
        If CStr(vA(r, 3)) <> CStr(vB(rb, 3)) Then
            wsA.Cells(rowA, rgA.Column + 2).Value = vB(rb, 3)
            wsLog.Cells(w, 1).Value = key
            wsLog.Cells(w, 2).Value = "名称"
            wsLog.Cells(w, 3).Value = vA(r, 3)
            wsLog.Cells(w, 4).Value = vB(rb, 3)
            wsLog.Cells(w, 5).Value = rowA
            w = w + 1
        End If
        '単価
        If CDbl(Val(vA(r, 4))) <> CDbl(Val(vB(rb, 4))) Then
            wsA.Cells(rowA, rgA.Column + 3).Value = CDbl(Val(vB(rb, 4)))
            wsLog.Cells(w, 1).Value = key
            wsLog.Cells(w, 2).Value = "単価"
            wsLog.Cells(w, 3).Value = CDbl(Val(vA(r, 4)))
            wsLog.Cells(w, 4).Value = CDbl(Val(vB(rb, 4)))
            wsLog.Cells(w, 5).Value = rowA
            w = w + 1
        End If
contA:
    Next

    wsLog.Rows(1).Font.Bold = True
    wsLog.Columns.AutoFit

    SpeedOff
End Sub
VB
  • ポイント
    • 年月の揺れは yyyy-mm 統一。
    • 区切りは「|」など安全な記号。

実務の落とし穴と対策

  • キー表記揺れで誤突合
    • 対策: NormKey（Trim＋UCase）。必要なら半角化や不要記号除去も加える。
  • 数値・日付の型ズレで誤判定
    • 対策: 数値は Val→CDbl、日付は IsDate→Format(“yyyy-mm-dd”) で比較・転記。
  • 列順変更で壊れる
    • 対策: 見出し名から列を特定（FindCol）。ハードコード禁止。
  • 転記の監査が難しい
    • 対策: 変更ログを必ず残す（コード/項目/旧/新）。必要なら元の値を別列に退避。

例題で練習

'例1：コードキーの変更セルだけをAへ反映
Sub Example_PatchBasic()
    PatchDiff_Cells_ByKey
End Sub

'例2：見出し名で項目を柔軟指定して変更セルだけ反映
Sub Example_PatchByHeaders()
    PatchDiff_Cells_ByHeaders
End Sub

'例3：変更セルだけを一覧に転記（監査用）
Sub Example_ExportDiff()
    ExportDiffCells_ToSheet
End Sub

'例4：複合キー（コード×年月）で変更セルだけ反映
Sub Example_PatchMultiKey()
    PatchDiff_Cells_MultiKey
End Sub
VB

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