Excel VBA 逆引き集 | 変更だけ更新

Excel VBA
スポンサーリンク

変更だけ更新

「前月Aと今月Bを比べて、変更されたところだけAを更新したい」——全部上書きするのではなく、差分セルだけを反映するテンプレです。初心者でも安心して使えるように、基本から応用まで例題を交えて解説します。

考え方の整理

  • 対象: AとBに同じキー（コードやID）がある行。
  • 処理: 値が違うセルだけ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
  • SpeedOn/Off: 無駄な再描画・再計算を止めて高速安定。
  • NormKey: Trim＋UCaseでキーの表記揺れを吸収。

基本テンプレ：コードキーで変更だけ更新

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

Sub UpdateOnlyChangedCells()
    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

    'B辞書（キー→行番号）
    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: Set wsLog = EnsureSheet("更新ログ", True)
    wsLog.Range("A1:D1").Value = Array("コード", "項目", "旧(A)", "新(B)")
    Dim rLog As Long: rLog = 2

    'Aを更新
    Dim r 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
        Dim rb As Long: rb = dictB(k)
        Dim rowA As Long: rowA = rgA.Row + r - 1

        '名称（文字）
        If CStr(vA(r, 2)) <> CStr(vB(rb, 2)) Then
            wsA.Cells(rowA, rgA.Column + 1).Value = vB(rb, 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(rb, 2)
            rLog = rLog + 1
        End If

        '単価（数値）
        Dim aPrice As Double: aPrice = CDbl(Val(vA(r, 3)))
        Dim bPrice As Double: bPrice = CDbl(Val(vB(rb, 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
    MsgBox "更新件数: " & rLog - 2
End Sub

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
  • ポイント
    • 変更セルだけ更新: 未一致キーは触らない。
    • ログ残し: 旧値と新値を記録して監査可能。

見出し名で柔軟対応（項目増減に強い）

比較・更新対象を見出し名で指定。増減に強く、数値/日付/文字で比較方法を自動切替。

Sub UpdateOnlyChanged_ByHeaders()
    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 = FindHeader(rgA.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    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) = 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 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

    '更新処理
    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 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
                Worksheets("A").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
    MsgBox "更新件数: " & rLog - 2
End Sub

'見出し検索
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

'ログ用シート作成
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

使い方の流れ

  1. シートA … 前月データ（更新対象）
  2. シートB … 今月データ（比較元）
  3. キー列 … 「コード」列で突合
  4. 比較項目 … 配列 fields に見出し名を並べる
  5. 実行すると、Aの差分セルだけ更新され、更新ログシートに旧値と新値が記録されます。

例題で練習

'例1：コードキーで名称・単価だけ更新
Sub Example_UpdateBasic()
    UpdateOnlyChangedCells
End Sub

'例2：見出し名で柔軟に項目指定して更新
Sub Example_UpdateByHeaders()
    UpdateOnlyChanged_ByHeaders
End Sub
VB

実務の落とし穴と対策

  • キー表記揺れで誤判定
    → NormKeyでTrim＋UCase。必要なら半角化も。
  • 数値・日付の型ズレ
    → Val→CDbl、Format("yyyy-mm-dd")で統一。
  • 列順変更で壊れる
    → FindHeaderで見出し名から列特定。
  • 更新内容が分からない
    → ログシートに旧値・新値を残す。
スポンサーリンク
タイトルとURLをコピーしました