Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – マスタ同期テンプレ

Excel VBA
スポンサーリンク

ねらい：マスタ同期を「差分抽出＋安全反映」の型にして、常に最新状態を保つ

マスタ同期は「旧データ」と「新データ」を比べて、追加・削除・変更を正しく見極め、旧マスタを最新に更新する作業です。Excel関数や手作業だと抜け・誤更新が起きがちですが、VBAなら“配列I/O＋Dictionary＋正規化＋差分ハッシュ”で一瞬・正確に処理できます。ここでは初心者でも貼って動くテンプレを、丸ごと置換（最も安全）と差分反映（柔軟）まで段階的に解説します。

共通基盤：配列I/O・キー正規化・比較列指定

一括読み書き・キー生成・列指定

' ModSync_Base.bas
Option Explicit
Private Const SEP As String = Chr$(30) ' 複合キーの安全な区切り

Public Function ReadRegion(ByVal ws As Worksheet, Optional ByVal topLeft As String = "A1") As Variant
    ReadRegion = ws.Range(topLeft).CurrentRegion.Value
End Function

Public Sub WriteBlock(ByVal ws As Worksheet, ByVal a As Variant, ByVal topLeft As String)
    ws.Range(topLeft).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Public Function NormKey(ByVal v As Variant) As String
    NormKey = LCase$(Trim$(CStr(v))) ' 大小無視・前後空白除去
End Function

Public Function MakeKey2(ByVal v1 As Variant, ByVal v2 As Variant) As String
    MakeKey2 = NormKey(v1) & SEP & NormKey(v2)
End Function

Public Function ColsToIndex(ByVal csv As String) As Long()
    Dim p() As String: p = Split(csv, ",")
    Dim idx() As Long: ReDim idx(0 To UBound(p))
    Dim i As Long
    For i = 0 To UBound(p): idx(i) = Range(Trim$(p(i)) & "1").Column: Next
    ColsToIndex = idx
End Function

Public Function RowHash(ByVal a As Variant, ByVal r As Long, ByVal idx() As Long) As String
    Dim i As Long, s As String
    For i = LBound(idx) To UBound(idx)
        s = s & NormKey(a(r, idx(i))) & "|" ' 正規化＋区切りで比較の粒度を固定
    Next
    RowHash = s ' 実務はSHA-256へ置換可能
End Function
VB

重要ポイントの深掘り

  • 正規化は両側で必須。片側のみ適用はヒット漏れや誤差分の原因になります。
  • 比較対象列は文字で指定（例：”B,D,F”）。列追加・入替にも壊れません。
  • ハッシュは「比較に使う列のみ」で作る。ノイズ（更新日時など）を含めないのがコツです。

差分抽出：追加・削除・変更の一括検出

単一キーで差分抽出（貼って動く）

' ModSync_Diff.bas
Option Explicit

' oldSheet: 旧マスタ（A=キー）
' newSheet: 新マスタ（A=キー）
' compareColsCsv: 比較対象列（例 "B,C,D"）
' outStart: 出力開始セル（例 "Z1"）
Public Sub ExtractDiff(ByVal oldSheet As String, ByVal newSheet As String, ByVal compareColsCsv As String, ByVal outStart As String)
    Dim o As Variant: o = ReadRegion(Worksheets(oldSheet))
    Dim n As Variant: n = ReadRegion(Worksheets(newSheet))
    Dim cmpIdx() As Long: cmpIdx = ColsToIndex(compareColsCsv)

    Dim dOld As Object: Set dOld = CreateObject("Scripting.Dictionary"): dOld.CompareMode = 1
    Dim hOld As Object: Set hOld = CreateObject("Scripting.Dictionary"): hOld.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(o, 1)
        Dim k As String: k = NormKey(o(r, 1))
        dOld(k) = r
        hOld(k) = RowHash(o, r, cmpIdx)
    Next

    Dim out() As Variant: ReDim out(1 To 1, 1 To 4)
    out(1, 1) = "Type": out(1, 2) = "Key": out(1, 3) = "OldHash": out(1, 4) = "NewHash"
    Dim rowsOut As Long: rowsOut = 1

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary"): seen.CompareMode = 1
    For r = 2 To UBound(n, 1)
        Dim k As String: k = NormKey(n(r, 1))
        Dim hn As String: hn = RowHash(n, r, cmpIdx)
        seen(k) = True
        If Not dOld.Exists(k) Then
            rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 4)
            out(rowsOut, 1) = "ADDED": out(rowsOut, 2) = k: out(rowsOut, 4) = hn
        ElseIf hOld(k) <> hn Then
            rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 4)
            out(rowsOut, 1) = "CHANGED": out(rowsOut, 2) = k: out(rowsOut, 3) = hOld(k): out(rowsOut, 4) = hn
        End If
    Next

    Dim k As Variant
    For Each k In dOld.Keys
        If Not seen.Exists(k) Then
            rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 4)
            out(rowsOut, 1) = "DELETED": out(rowsOut, 2) = k: out(rowsOut, 3) = hOld(k)
        End If
    Next

    WriteBlock Worksheets(oldSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • ADDED/DELETED/CHANGEDの3種が一度に抽出でき、レビュー負荷が激減します。
  • ハッシュ比較は「実質的な変更」だけを拾うための鍵。比較列の選定が品質を決めます。

同期のやり方①：丸ごと置換（最も安全でシンプル）

完全置換テンプレ

' ModSync_Replace.bas
Option Explicit

' 旧マスタを新マスタで丸ごと置換する（推奨：まずはこの方式で運用安定化）
Public Sub SyncByReplace(ByVal oldSheet As String, ByVal newSheet As String)
    Dim n As Variant: n = ReadRegion(Worksheets(newSheet))
    Worksheets(oldSheet).Cells.Clear
    Worksheets(oldSheet).Range("A1").Resize(UBound(n, 1), UBound(n, 2)).Value = n
End Sub
VB

重要ポイントの深掘り

  • 誤更新を根絶しやすい。差分確認後に一発置換で「常に最新」にできます。
  • 履歴や監査が必要なら、置換前に旧マスタをアーカイブ（別シート・CSV）保存しておくと安全です。

同期のやり方②：差分だけ反映（追加・削除・変更）

差分反映テンプレ（柔軟だが設計が要る）

' ModSync_ApplyDiff.bas
Option Explicit

' 比較対象列のみ更新し、追加・削除も反映。順序維持が不要な前提。
Public Sub SyncByApplyDiff(ByVal oldSheet As String, ByVal newSheet As String, ByVal compareColsCsv As String, Optional ByVal deleteModeClear As Boolean = True)
    Dim o As Variant: o = ReadRegion(Worksheets(oldSheet))
    Dim n As Variant: n = ReadRegion(Worksheets(newSheet))
    Dim cmpIdx() As Long: cmpIdx = ColsToIndex(compareColsCsv)

    ' 新マスタ辞書（key → 行番号）
    Dim dNew As Object: Set dNew = CreateObject("Scripting.Dictionary"): dNew.CompareMode = 1
    Dim r As Long: For r = 2 To UBound(n, 1): dNew(NormKey(n(r, 1))) = r: Next

    ' 旧→変更/削除反映
    For r = 2 To UBound(o, 1)
        Dim k As String: k = NormKey(o(r, 1))
        If dNew.Exists(k) Then
            Dim rr As Long: rr = dNew(k)
            Dim c As Long
            For c = LBound(cmpIdx) To UBound(cmpIdx)
                If CStr(o(r, cmpIdx(c))) <> CStr(n(rr, cmpIdx(c))) Then
                    o(r, cmpIdx(c)) = n(rr, cmpIdx(c)) ' 変更反映
                End If
            Next
        Else
            ' 削除反映：空白化 or 実削除
            If deleteModeClear Then
                Dim c As Long: For c = 1 To UBound(o, 2): o(r, c) = "": Next
            Else
                ' 実削除は行の再構築が必要：簡潔さ重視なら空白化を推奨
            End If
        End If
    Next

    ' 追加反映：旧に無いキーを末尾追加
    Dim rowsOut As Long: rowsOut = UBound(o, 1)
    Dim k As Variant
    For Each k In dNew.Keys
        Dim found As Boolean: found = False
        For r = 2 To UBound(o, 1)
            If NormKey(o(r, 1)) = k Then found = True: Exit For
        Next
        If Not found Then
            rowsOut = rowsOut + 1: ReDim Preserve o(1 To rowsOut, 1 To UBound(n, 2))
            Dim rr As Long: rr = dNew(k)
            Dim c As Long: For c = 1 To UBound(n, 2): o(rowsOut, c) = n(rr, c): Next
        End If
    Next

    WriteBlock Worksheets(oldSheet), o, "A1"
End Sub
VB

重要ポイントの深掘り

  • 削除の扱いは運用で決める（空白化＝監査しやすい／実削除＝データ軽量）。まずは空白化が安全。
  • 追加は末尾に入るため、順序重視なら最後に安定ソートを入れると良いです。
  • 比較列に「更新日時」などを入れると毎回CHANGEDになるので、業務に効く列だけ選定します。

変更詳細の可視化：どの列が変わったかを示す

列別の変更一覧テンプレ

' ModSync_ChangedDetail.bas
Option Explicit

Public Sub ListChangedColumns(ByVal oldSheet As String, ByVal newSheet As String, ByVal compareColsCsv As String, ByVal outStart As String)
    Dim o As Variant: o = ReadRegion(Worksheets(oldSheet))
    Dim n As Variant: n = ReadRegion(Worksheets(newSheet))
    Dim idx() As Long: idx = ColsToIndex(compareColsCsv)

    Dim dOldRow As Object: Set dOldRow = CreateObject("Scripting.Dictionary"): dOldRow.CompareMode = 1
    Dim r As Long: For r = 2 To UBound(o, 1): dOldRow(NormKey(o(r, 1))) = r: Next

    Dim out() As Variant: ReDim out(1 To 1, 1 To 5)
    out(1, 1) = "Key": out(1, 2) = "Column": out(1, 3) = "Old": out(1, 4) = "New": out(1, 5) = "Changed"
    Dim rowsOut As Long: rowsOut = 1

    Dim c As Long
    For r = 2 To UBound(n, 1)
        Dim k As String: k = NormKey(n(r, 1))
        If dOldRow.Exists(k) Then
            Dim ro As Long: ro = dOldRow(k)
            For c = LBound(idx) To UBound(idx)
                Dim col As Long: col = idx(c)
                Dim oldVal As String: oldVal = CStr(o(ro, col))
                Dim newVal As String: newVal = CStr(n(r, col))
                If oldVal <> newVal Then
                    rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 5)
                    out(rowsOut, 1) = k
                    out(rowsOut, 2) = Worksheets(oldSheet).Cells(1, col).Value
                    out(rowsOut, 3) = oldVal
                    out(rowsOut, 4) = newVal
                    out(rowsOut, 5) = "Y"
                End If
            Next
        End If
    Next
    WriteBlock Worksheets(oldSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • 列名付きでOld→Newを見せると承認・修正が速い。色分け（黄）で“変化”を強調するとさらに楽です。
  • 値比較の正規化方針（大小無視・空白除去）を事前に合意しておくと、誤判定が減ります。

例題の通し方：商品マスタの差分→確認→同期

実行例

' ModSync_Example.bas
Option Explicit

Public Sub Demo_MasterSync()
    ' 1) 差分抽出（比較対象はB,C）
    ExtractDiff "Master_Old", "Master_New", "B,C", "Z1"
    ' 2) 変更詳細（列別差分）
    ListChangedColumns "Master_Old", "Master_New", "B,C", "AA1"
    ' 3a) 最も安全：丸ごと置換
    SyncByReplace "Master_Old", "Master_New"
    ' 3b) 柔軟：差分だけ反映（選択）
    ' SyncByApplyDiff "Master_Old", "Master_New", "B,C", True
    MsgBox "商品マスタの同期が完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

  • ADDED/DELETED/CHANGEDが正しく分類され、列別の変更詳細も出る。
  • 同期後、旧マスタは最新状態。必要なら差分だけ反映へ切替可能。

運用の深掘り：安全装置・見える化・拡張

運用の安全装置

  • 同期前に旧マスタをCSVへ自動バックアップ。万一の巻き戻しが即可能。
  • 差分件数（Added/Deleted/Changed）をメッセージとログに出すと監査が楽になります。

見える化

  • 差分一覧に条件付き書式（ADDED=緑／DELETED=赤／CHANGED=黄）。レビューが一目で終わる。
  • 種別別シートへ分割すると承認／配布がスムーズ。

拡張ポイント

  • 複合キー（MakeKey2）や多列返却に対応。
  • ハッシュをSHA-256に差し替え（より堅牢）。
  • 順序維持が必要なら、同期後に安定ソート（キー列で）を標準化。

落とし穴と対策（深掘り）

正規化不足で誤差分

Trim/LCaseを両側に適用。必要なら全半角統一や記号除去の前処理も追加。

比較列にノイズが含まれる

更新日時・備考などは比較対象から外す。業務に効く列のみで差分を作る。

削除の扱いが曖昧

空白化か実削除かを最初に決める。監査がある現場は空白化が無難。

セル逐次書きで遅い

結果は配列で作成し、一括書き戻し。10万行でも高速でUIが固まりません。

まとめ：マスタ同期は「差分抽出＋（置換 or 差分反映）」を型にして安定運用へ

  • 差分抽出で“何が変わったか”を明示、最初は丸ごと置換で安全に最新化。
  • 仕様が固まったら差分反映で柔軟に更新。削除方針・比較列設計・正規化を先に決める。
  • 配列I/O＋Dictionary＋正規化＋一括書き戻しの型を守れば、規模が大きくても壊れません。

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