2段階差分
「差分を一度に全部出すのではなく、2段階に分けて確認・適用したい」——例えば「まず差分レポートを作成（プレビュー）、次に承認したものだけ更新・同期」する流れです。初心者でも理解しやすいように、コード例とテンプレをかみ砕いて説明します。
2段階差分の考え方
- 第1段階（プレビュー）:
新規／削除／変更を一覧化して別シートに出力。ここでは元データは触らない。 - 第2段階（適用）:
プレビュー結果を見て承認したら、実際にマスタへ反映（追加・削除・更新）。
この流れなら「誤更新」を防ぎやすく、チームで確認してから適用できます。
共通ユーティリティ（速度・安全）
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
第1段階：差分レポート作成（プレビュー）
「A: マスタ」「B: 実績」を比較し、新規／削除／変更を別シートに出力します。
Sub PreviewDiff()
SpeedOn
Dim vA As Variant: vA = Worksheets("A").Range("A1").CurrentRegion.Value
Dim vB As Variant: vB = Worksheets("B").Range("A1").CurrentRegion.Value
'キー列は1列目（コード）想定
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 wsNew As Worksheet: Set wsNew = EnsureSheet("新規候補", True)
Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除候補", True)
Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更候補", True)
wsNew.Range("A1:C1").Value = Array("コード", "名称(B)", "単価(B)")
wsDel.Range("A1:C1").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, 1))
If Len(k) = 0 Then GoTo contA
If dictB.Exists(k) Then
Dim rb As Long: rb = dictB(k)
'名称
If CStr(vA(i, 2)) <> CStr(vB(rb, 2)) Then
wsChg.Cells(rChg, 1).Value = vA(i, 1)
wsChg.Cells(rChg, 2).Value = "名称"
wsChg.Cells(rChg, 3).Value = vA(i, 2)
wsChg.Cells(rChg, 4).Value = vB(rb, 2)
rChg = rChg + 1
End If
'単価
Dim aPrice As Double: aPrice = CDbl(Val(vA(i, 3)))
Dim bPrice As Double: bPrice = CDbl(Val(vB(rb, 3)))
If aPrice <> bPrice Then
wsChg.Cells(rChg, 1).Value = vA(i, 1)
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, 1)
wsDel.Cells(rDel, 2).Value = vA(i, 2)
wsDel.Cells(rDel, 3).Value = vA(i, 3)
rDel = rDel + 1
End If
contA:
Next
'Bのみ（新規）
Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(vA, 1)
setA(NormKey(vA(i, 1))) = True
Next
Dim j As Long
For j = 2 To UBound(vB, 1)
k = NormKey(vB(j, 1))
If Len(k) > 0 And Not setA.Exists(k) Then
wsNew.Cells(rNew, 1).Value = vB(j, 1)
wsNew.Cells(rNew, 2).Value = vB(j, 2)
wsNew.Cells(rNew, 3).Value = vB(j, 3)
rNew = rNew + 1
End If
Next
SpeedOff
MsgBox "プレビュー完了: 新規=" & rNew - 2 & " 削除=" & rDel - 2 & " 変更=" & rChg - 2
End Sub
- ポイント
- 元データは触らず、候補シートに出力。
- 差分件数をMsgBoxで確認。
第2段階：差分適用（更新・追加・削除）
プレビュー結果を見て承認したら、マスタ（A）へ反映します。
Sub ApplyDiff()
SpeedOn
Dim wsA As Worksheet: Set wsA = Worksheets("A")
Dim rgA As Range: Set rgA = wsA.Range("A1").CurrentRegion
Dim vA As Variant: vA = rgA.Value
'削除候補シートから削除
Dim wsDel As Worksheet: Set wsDel = Worksheets("削除候補")
Dim lastRowDel As Long: lastRowDel = wsDel.Cells(wsDel.Rows.Count, 1).End(xlUp).Row
Dim i As Long, k As String
For i = lastRowDel To 2 Step -1
k = NormKey(wsDel.Cells(i, 1).Value)
Dim r As Long
For r = rgA.Rows.Count To 2 Step -1
If NormKey(vA(r, 1)) = k Then wsA.Rows(rgA.Row + r - 1).Delete
Next
Next
'新規候補シートから追加
Dim wsNew As Worksheet: Set wsNew = Worksheets("新規候補")
Dim lastRowNew As Long: lastRowNew = wsNew.Cells(wsNew.Rows.Count, 1).End(xlUp).Row
Dim nextRow As Long: nextRow = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row + 1
For i = 2 To lastRowNew
wsA.Cells(nextRow, 1).Value = wsNew.Cells(i, 1).Value
wsA.Cells(nextRow, 2).Value = wsNew.Cells(i, 2).Value
wsA.Cells(nextRow, 3).Value = wsNew.Cells(i, 3).Value
nextRow = nextRow + 1
Next
'変更候補シートから更新
Dim wsChg As Worksheet: Set wsChg = Worksheets("変更候補")
Dim lastRowChg As Long: lastRowChg = wsChg.Cells(wsChg.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRowChg
k = NormKey(wsChg.Cells(i, 1).Value)
Dim itemName As String: itemName = wsChg.Cells(i, 2).Value
Dim newVal As Variant: newVal = wsChg.Cells(i, 4).Value
'Aシートを探して更新
Dim r As Long
For r = 2 To rgA.Rows.Count
If NormKey(vA(r, 1)) = k Then
Select Case itemName
Case "名称"
wsA.Cells(rgA.Row + r - 1, 2).Value = newVal
Case "単価"
wsA.Cells(rgA.Row + r - 1, 3).Value = newVal
End Select
End If
Next
Next
wsA.Rows(1).Font.Bold = True
wsA.Columns.AutoFit
SpeedOff
MsgBox "差分適用完了"
End Sub
処理の流れまとめ
- 削除候補シートにあるコードを探して、Aから削除。
- 新規候補シートにある行をAの末尾に追加。
- 変更候補シートにある項目をAで更新。
最後に「差分適用完了」とメッセージが出ます。
例題で練習
'例1：差分プレビュー（新規・削除・変更を候補シートに出力）
Sub Example_Preview()
PreviewDiff
End Sub
'例2：プレビュー結果を承認後に適用
Sub Example_Apply()
ApplyDiff
End Sub
初心者向けポイント
- 2段階に分ける理由:
いきなり更新すると誤操作のリスクが高い。まず候補を出して確認できる安心設計。 - 候補シート:
「新規候補」「削除候補」「変更候補」に分けることで、承認フローが明確。 - 更新処理:
Select Caseで項目ごとに更新先列を分ける。項目が増えたらここに追加すればOK。