Excel VBA 逆引き集 | 新規だけ追加

Excel VBA
スポンサーリンク

新規だけ追加

「前月Aに、今月Bの“新規行だけ”を追加入力したい」——重複はスキップして安全に追加するテンプレです。初心者でも壊れないコツは「キーの正規化」「見出し名で列特定」「配列＋辞書」「一括転記」。

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

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 EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = False) 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 NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function
VB
  • 速度: 画面/イベント/計算を止めてから処理→復帰。
  • 正規化: Trim + UCaseでキーの表記揺れを吸収。
  • EnsureSheet: ログ用や出力用シートを安全に用意。

最短テンプレ：AにBの“新規行だけ”末尾追加（キー＝コード）

見出しはA・Bとも「コード/名称/単価」想定。重複キーは追加しません。

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

    'Aの既存キー集合
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, 1))
        If Len(k) > 0 Then setA(k) = True
    Next

    '追加件数カウント
    Dim added As Long: added = 0

    'Bを走査して未存在キーだけA末尾へ追記
    Dim nextRow As Long: nextRow = rgA.Row + rgA.Rows.Count 'CurrentRegionの直下
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, 1))
        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)
            nextRow = nextRow + 1
            added = added + 1
        End If
    Next

    '見やすさ
    wsA.Rows(1).Font.Bold = True
    wsA.Columns.AutoFit

    SpeedOff
    MsgBox "新規追加: " & added & "件"
End Sub
VB
  • ポイント
    • CurrentRegionの直下に追記: 既存表の次行に安全に追加。
    • 重複スキップ: 既存キー辞書で判定して追加ミスを防ぐ。

見出し名で列特定（列順変更に強い）版

現場で列増減や順序が変わっても壊れません。見出し不足なら停止します。

Sub AppendOnlyNew_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

    'A既存キー
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKeyA))
        If Len(k) > 0 Then setA(k) = True
    Next

    'B→A追記（列はBの見出しに揃えてAの末尾へ）
    'ヘッダー整合が必要なら、列マップを作る（A/B共通見出しだけ追記）
    Dim map() As Long
    Dim headersCount As Long: headersCount = rgB.Columns.Count
    ReDim map(1 To headersCount)
    Dim c As Long
    For c = 1 To headersCount
        Dim h As String: h = CStr(vB(1, c))
        Dim pos As Long: pos = FindHeader(rgA.Rows(1), h)
        map(c) = pos 'A側で同名見出しの列。無ければ0
    Next

    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, cKeyB))
        If Len(k) > 0 And Not setA.Exists(k) Then
            'A側に存在する見出しだけ値を入れる（無い見出しはスキップ）
            For c = 1 To headersCount
                If map(c) > 0 Then
                    wsA.Cells(nextRow, map(c)).Value = vB(i, c)
                End If
            Next
            nextRow = nextRow + 1
            added = added + 1
        End If
    Next

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

    SpeedOff
    MsgBox "新規追加: " & added & "件（共通見出しのみ反映）"
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
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 AppendOnlyNew_MultiKey()
    SpeedOn

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

    '既存複合キー集合（A）
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    Dim i As Long
    For i = 2 To UBound(vA, 1)
        setA(BuildKey2(vA(i, 1), vA(i, 2))) = True
    Next

    '追加
    Dim nextRow As Long: nextRow = rgA.Row + rgA.Rows.Count
    Dim added As Long: added = 0
    For i = 2 To UBound(vB, 1)
        Dim key As String: key = BuildKey2(vB(i, 1), vB(i, 2))
        If Not setA.Exists(key) Then
            wsA.Cells(nextRow, rgA.Column).Resize(1, rgA.Columns.Count).Value = _
                Application.Index(vB, i, 0)
            nextRow = nextRow + 1
            added = added + 1
        End If
    Next

    wsA.Rows(1).Font.Bold = True
    wsA.Columns.AutoFit
    SpeedOff
    MsgBox "新規（複合キー）追加: " & added & "件"
End Sub
VB
  • ポイント
    • 年月統一: yyyy-mm固定で表記揺れ防止。
    • 安全区切り: 連結は「|」などを使用。

追加前に検証レポート（何が新規かを一覧）

追加する前に「新規候補」を確認したいとき。後で承認フローにも使えます。

Sub PreviewNewRows()
    SpeedOn

    Dim vA As Variant: vA = Worksheets("A").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("B").Range("A1").CurrentRegion.Value

    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    Dim i As Long: For i = 2 To UBound(vA, 1): setA(NormKey(vA(i, 1))) = True: Next

    Dim ws As Worksheet: Set ws = EnsureSheet("新規候補", True)
    ws.Range("A1").Resize(1, UBound(vB, 2)).Value = Application.Index(vB, 1, 0)
    Dim w As Long: w = 2

    For i = 2 To UBound(vB, 1)
        Dim k As String: k = NormKey(vB(i, 1))
        If Len(k) > 0 And Not setA.Exists(k) Then
            ws.Range("A" & w).Resize(1, UBound(vB, 2)).Value = Application.Index(vB, i, 0)
            w = w + 1
        End If
    Next

    ws.Rows(1).Font.Bold = True
    ws.Columns.AutoFit
    SpeedOff
    MsgBox "新規候補: " & (w - 2) & "件"
End Sub
VB
  • ポイント
    • 承認前確認: 追記前に“差分候補”を一覧化。

実務の落とし穴と対策

  • キー表記揺れで重複判定ミス
    • 対策: NormKey（Trim＋UCase）。必要なら半角化・不要記号除去も検討。
  • 列順や見出しの不一致
    • 対策: 見出し名で列特定し、共通見出しのみ反映する設計に。
  • 数値・日付の型ズレで後工程が混乱
    • 対策: 追加後に列書式を統一（数値は標準/会計、日付は yyyy-mm）。
  • CurrentRegionが余計な空白や合計行を含む
    • 対策: 範囲を明示指定（例：A1:D & 最終行）に変えるか、合計行は別に切り出す。

例題で練習

'例1：単一キーで新規だけ末尾追加
Sub Example_AppendBasic()
    AppendOnlyNew_Basic
End Sub

'例2：見出し名で列特定して新規だけ追加（共通見出しのみ）
Sub Example_AppendByHeaders()
    AppendOnlyNew_ByHeaders
End Sub

'例3：複合キー（コード×年月）で新規だけ追加
Sub Example_AppendMultiKey()
    AppendOnlyNew_MultiKey
End Sub

'例4：追加前に新規候補を一覧化
Sub Example_PreviewNew()
    PreviewNewRows
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました