Excel VBA 逆引き集 | マスタと実績の同期

Excel VBA
スポンサーリンク

マスタと実績の同期

「マスタ（A）と実績（B）の差を取り、Aに“必要な変化だけ”反映する」ためのテンプレです。基本は「新規は追加」「削除は削除」「変更は更新」を安全に順序立てて実行し、監査用ログも残します。

同期の考え方

  • 対象: キー（例：コード）でAとBを突合。
  • 処理順序:
    1. 削除（AにあってBにない行）
    2. 追加（BにあってAにない行）
    3. 更新（両側にあるが値が違うセル）
  • 安全策: キーの正規化、見出し名で列特定、下から削除、更新ログの記録。

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

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 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
  • ポイント
    • 速度: 画面更新・イベント・計算を止めて安定。
    • 正規化: Trim + UCaseでキーの揺れを吸収。
    • 見出し: FindHeaderで列順変更に強くする。

基本同期テンプレ（単一キー：コード）

「Aを“マスタ”、Bを“実績”として同期」します。削除→追加→更新の順に適用し、ログに記録します。

Sub Sync_Master_With_Actuals_Basic()
    SpeedOn

    '前提：A=マスタ（更新対象）、B=実績（最新）
    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=単価, 4=在庫（必要に応じて変更）
    Dim cKey As Long: cKey = 1

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

    'ログ
    Dim wsLog As Worksheet: Set wsLog = EnsureSheet("同期ログ", True)
    wsLog.Range("A1:E1").Value = Array("操作", "コード", "項目", "旧(A)", "新(B)")
    Dim rLog As Long: rLog = 2

    '1) 削除（Aのみ）
    Dim delRows As Collection: Set delRows = New Collection
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKey))
        If Len(k) > 0 And Not mapB.Exists(k) Then
            delRows.Add rgA.Row + i - 1
            wsLog.Cells(rLog, 1).Value = "削除"
            wsLog.Cells(rLog, 2).Value = vA(i, cKey)
            wsLog.Cells(rLog, 3).Value = "(行)"
            wsLog.Cells(rLog, 4).Value = "" '旧行
            wsLog.Cells(rLog, 5).Value = "" '新行
            rLog = rLog + 1
        End If
    Next
    Dim r As Long
    For r = delRows.Count To 1 Step -1
        wsA.Rows(delRows(r)).Delete
    Next

    'Aの最新範囲を再取得（削除後）
    Set rgA = wsA.Range("A1").CurrentRegion
    vA = rgA.Value

    'A辞書（キー存在判定用）
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKey))
        If Len(k) > 0 Then setA(k) = True
    Next

    '2) 追加（Bのみ）
    Dim nextRow As Long: nextRow = rgA.Row + rgA.Rows.Count
    Dim added As Long: added = 0
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cKey))
        If Len(k) > 0 And Not setA.Exists(k) Then
            wsA.Cells(nextRow, rgA.Column).Resize(1, rgA.Columns.Count).Value = Application.Index(vB, i, 0)
            wsLog.Cells(rLog, 1).Value = "追加"
            wsLog.Cells(rLog, 2).Value = vB(i, cKey)
            wsLog.Cells(rLog, 3).Value = "(行)"
            wsLog.Cells(rLog, 4).Value = "" '旧なし
            wsLog.Cells(rLog, 5).Value = "" '新行
            rLog = rLog + 1
            nextRow = nextRow + 1
            added = added + 1
        End If
    Next

    'Aの最新範囲を再取得（追加後）
    Set rgA = wsA.Range("A1").CurrentRegion
    vA = rgA.Value

    'A辞書（行番号）を刷新
    Dim mapA As Object: Set mapA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKey))
        If Len(k) > 0 Then mapA(k) = i
    Next

    '3) 更新（両側あり、値が違う項目のみ）
    For Each k In mapB.Keys
        If mapA.Exists(k) Then
            Dim ra As Long: ra = mapA(k)
            Dim rb As Long: rb = mapB(k)
            '名称（文字）
            If CStr(vA(ra, 2)) <> CStr(vB(rb, 2)) Then
                wsA.Cells(rgA.Row + ra - 1, rgA.Column + 1).Value = vB(rb, 2)
                wsLog.Cells(rLog, 1).Value = "更新"
                wsLog.Cells(rLog, 2).Value = vA(ra, cKey)
                wsLog.Cells(rLog, 3).Value = "名称"
                wsLog.Cells(rLog, 4).Value = vA(ra, 2)
                wsLog.Cells(rLog, 5).Value = vB(rb, 2)
                rLog = rLog + 1
            End If
            '単価（数値）
            Dim aPrice As Double: aPrice = CDbl(Val(vA(ra, 3)))
            Dim bPrice As Double: bPrice = CDbl(Val(vB(rb, 3)))
            If aPrice <> bPrice Then
                wsA.Cells(rgA.Row + ra - 1, rgA.Column + 2).Value = bPrice
                wsLog.Cells(rLog, 1).Value = "更新"
                wsLog.Cells(rLog, 2).Value = vA(ra, cKey)
                wsLog.Cells(rLog, 3).Value = "単価"
                wsLog.Cells(rLog, 4).Value = aPrice
                wsLog.Cells(rLog, 5).Value = bPrice
                rLog = rLog + 1
            End If
            '在庫（数値）
            Dim aStock As Double: aStock = CDbl(Val(vA(ra, 4)))
            Dim bStock As Double: bStock = CDbl(Val(vB(rb, 4)))
            If aStock <> bStock Then
                wsA.Cells(rgA.Row + ra - 1, rgA.Column + 3).Value = bStock
                wsLog.Cells(rLog, 1).Value = "更新"
                wsLog.Cells(rLog, 2).Value = vA(ra, cKey)
                wsLog.Cells(rLog, 3).Value = "在庫"
                wsLog.Cells(rLog, 4).Value = aStock
                wsLog.Cells(rLog, 5).Value = bStock
                rLog = rLog + 1
            End If
        End If
    Next

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

    SpeedOff
    MsgBox "削除:" & delRows.Count & " / 追加:" & added & " / 更新:" & (rLog - 2 - delRows.Count - added)
End Sub
VB
  • ポイント
    • 順序が大事: 削除→追加→更新で整合性を保つ。
    • 一括貼付＋辞書: 大量データでも実用速度。
    • ログで監査: 実行後の差分確認が楽。

見出し名で同期（列増減に強い）

見出し名で比較・更新対象を選べる版。項目が増減しても壊れません。

Sub Sync_Master_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 keyHeader As String: keyHeader = "コード"
    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), keyHeader)
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), keyHeader)
    If cKeyA = 0 Or cKeyB = 0 Then SpeedOff: MsgBox "キー見出し不足": Exit Sub

    '同期対象の見出し（増減可能）
    Dim fields As Variant: fields = Array("名称", "カテゴリ", "単価", "在庫")

    '列マップ（A/B）
    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 delRows As Collection: Set delRows = New Collection
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) > 0 And Not mapBRow.Exists(k) Then delRows.Add rgA.Row + r - 1
    Next
    Dim x As Long
    For x = delRows.Count To 1 Step -1
        wsA.Rows(delRows(x)).Delete
    Next

    'A再取得＋A集合
    Set rgA = wsA.Range("A1").CurrentRegion
    vA = rgA.Value
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) > 0 Then setA(k) = True
    Next

    '追加（Bのみ）——共通見出しだけ反映
    Dim nextRow As Long: nextRow = rgA.Row + rgA.Rows.Count
    Dim added As Long: added = 0
    For r = 2 To UBound(vB, 1)
        k = NormKey(vB(r, cKeyB))
        If Len(k) > 0 And Not setA.Exists(k) Then
            'キー
            wsA.Cells(nextRow, cKeyA).Value = vB(r, cKeyB)
            '同期対象フィールド
            For i = LBound(fields) To UBound(fields)
                wsA.Cells(nextRow, mapA(i)).Value = vB(r, mapB(i))
            Next
            nextRow = nextRow + 1
            added = added + 1
        End If
    Next

    '更新（両側あり：対象フィールドのみ）
    Dim wsLog As Worksheet: Set wsLog = EnsureSheet("同期ログ", True)
    wsLog.Range("A1:E1").Value = Array("操作", "コード", "項目", "旧(A)", "新(B)")
    Dim rLog As Long: rLog = 2

    'Aの行マップ
    Dim mapARow As Object: Set mapARow = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) > 0 Then mapARow(k) = r
    Next

    For Each k In mapBRow.Keys
        If mapARow.Exists(k) Then
            Dim ra As Long: ra = mapARow(k)
            Dim rb As Long: rb = mapBRow(k)
            For i = LBound(fields) To UBound(fields)
                Dim va As Variant: va = vA(ra, 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)))
                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(rgA.Row + ra - 1, mapA(i)).Value = vb
                    wsLog.Cells(rLog, 1).Value = "更新"
                    wsLog.Cells(rLog, 2).Value = vA(ra, cKeyA)
                    wsLog.Cells(rLog, 3).Value = fields(i)
                    wsLog.Cells(rLog, 4).Value = va
                    wsLog.Cells(rLog, 5).Value = vb
                    rLog = rLog + 1
                End If
            Next
        End If
    Next

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

    SpeedOff
    MsgBox "削除:" & delRows.Count & " / 追加:" & added & " / 更新:" & (rLog - 2)
End Sub
VB
  • ポイント
    • 共通見出しのみ反映で整合性を担保。
    • 型別比較で誤判定を防ぐ。

実績を集計してマスタへ反映（数量合計・最新単価）

「実績を集計して、マスタに“合計数量”や“最新単価”を反映」する定番パターンです。

Sub Sync_Aggregates_From_Actuals()
    SpeedOn

    'A: マスタ（コード/名称/単価/合計数量）
    'B: 実績（コード/日付/数量/単価）
    Dim vA As Variant: vA = Worksheets("A").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("B").Range("A1").CurrentRegion.Value

    '列想定（必要ならFindHeaderで置換）
    Dim cCodeA As Long: cCodeA = 1
    Dim cNameA As Long: cNameA = 2
    Dim cPriceA As Long: cPriceA = 3
    Dim cSumQtyA As Long: cSumQtyA = 4
    Dim cCodeB As Long: cCodeB = 1
    Dim cDateB As Long: cDateB = 2
    Dim cQtyB  As Long: cQtyB  = 3
    Dim cPriceB As Long: cPriceB = 4

    '集計辞書（コード→数量合計、最新日付単価）
    Dim sumQty As Object: Set sumQty = CreateObject("Scripting.Dictionary")
    Dim lastDate As Object: Set lastDate = CreateObject("Scripting.Dictionary")
    Dim lastPrice As Object: Set lastPrice = CreateObject("Scripting.Dictionary")

    Dim i As Long, k As String, d As Date
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cCodeB))
        If Len(k) = 0 Then GoTo nextB
        sumQty(k) = CDbl(Val(sumQty(k))) + CDbl(Val(vB(i, cQtyB)))
        If IsDate(vB(i, cDateB)) Then
            d = CDate(vB(i, cDateB))
            If Not lastDate.Exists(k) Or d > lastDate(k) Then
                lastDate(k) = d
                lastPrice(k) = CDbl(Val(vB(i, cPriceB)))
            End If
        End If
nextB:
    Next

    'Aへ反映（合計数量・最新単価）
    Dim wsA As Worksheet: Set wsA = Worksheets("A")
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cCodeA))
        If sumQty.Exists(k) Then wsA.Cells(i, cSumQtyA).Value = sumQty(k)
        If lastPrice.Exists(k) Then wsA.Cells(i, cPriceA).Value = lastPrice(k)
    Next

    wsA.Rows(1).Font.Bold = True
    wsA.Columns.AutoFit
    SpeedOff
    MsgBox "集計同期完了"
End Sub
VB
  • ポイント
    • 最新単価は「最新日付のレコードから採用」。
    • 数量合計は辞書で累積して高速。

二段同期フロー（プレビュー→適用）

いきなり書き換えず、まず「差分レポート」を出して確認→OKなら適用、が安全です。

  • プレビュー: 新規・削除・更新の一覧を別シートに出力。
  • 適用: プレビュー結果を元に、承認された項目だけ適用（削除→追加→更新）。

この運用なら「誤更新」を避けやすく、チーム共有にも向きます。

よくある落とし穴と対策

  • キー表記揺れで誤判定
    • 対策: NormKey（Trim＋UCase）。必要なら半角化・記号除去。
  • 数値・日付の型ズレ
    • 対策: Val→CDbl、Format(“yyyy-mm-dd”)で統一して比較。
  • 削除順で事故
    • 対策: 必ず下から削除。途中で範囲を取り直す。
  • 列順変更で壊れる
    • 対策: FindHeaderで見出しから列特定。ハードコード禁止。
  • 実績の重複キー
    • 対策: 集計時に辞書で累積、最新ロジックを明確化。

例題で練習

'例1：単一キーで削除→追加→更新の基本同期
Sub Example_SyncBasic()
    Sync_Master_With_Actuals_Basic
End Sub

'例2：見出し名で項目指定して同期（増減に強い）
Sub Example_SyncByHeaders()
    Sync_Master_ByHeaders
End Sub

'例3：実績から合計数量・最新単価をマスタへ同期
Sub Example_SyncAggregates()
    Sync_Aggregates_From_Actuals
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました