Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – 顧客リスト更新

Excel VBA
スポンサーリンク

ねらい：顧客リストを「正規化→重複処理→差分反映→出力整形」まで一括で安全更新する

顧客リスト更新は、入力ゆれの正規化、重複の見える化と解消、既存マスタとの差分抽出と同期、最終の書式整備までを一気通貫で回すと事故が激減します。配列I/O＋Dictionary＋正規化＋差分ハッシュの型で、列変更にも強く、十万件でも一瞬で処理できます。初心者が貼って動かせる再利用部品として、例題付きでかみ砕いて解説します。

共通基盤：配列I/O・キー正規化・列指定・軽量バリデーション

一括読み書き・キー生成・列指定ユーティリティ

' ModCust_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 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 CleanPhone(ByVal s As String) As String
    Dim t As String: t = Replace(Replace(Replace(s, "-", ""), " ", ""), "　", "")
    CleanPhone = t ' ハイフン・空白除去（詳細ルールは現場仕様に合わせて）
End Function

Public Function CleanEmail(ByVal s As String) As String
    CleanEmail = LCase$(Trim$(s))
End Function
VB

重要ポイントの深掘り

  • 正規化の徹底: IDやメール、電話番号は必ず同じ関数で正規化します。片側だけの正規化はヒット漏れの原因です。
  • 列の文字指定: “B,D,F” のような列指定でテンプレを設計すると、列追加・入替でも壊れません。
  • 軽量バリデーション: 電話はハイフン・空白除去、メールは前後空白と大小統一。厳密判定は後段の監査用に分離します。

明細整形：入力ゆれの補正と派生列（キー・都道府県・連絡先）

顧客明細クリーニングと派生列付与

' ModCust_Clean.bas
Option Explicit

' Data: A=顧客ID, B=氏名, C=メール, D=電話, E=住所, F=登録日
' 出力：CustKey, EmailNorm, PhoneNorm, Prefecture を付与
Public Sub CleanCustomerDetail(ByVal sheetName As String, ByVal outStart As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)
    Dim out() As Variant: ReDim out(1 To UBound(a, 1), 1 To UBound(a, 2) + 4)

    Dim lastCol As Long: lastCol = UBound(a, 2)
    Dim c As Long
    For c = 1 To lastCol: out(1, c) = a(1, c): Next
    out(1, lastCol + 1) = "CustKey"
    out(1, lastCol + 2) = "EmailNorm"
    out(1, lastCol + 3) = "PhoneNorm"
    out(1, lastCol + 4) = "Prefecture"

    Dim r As Long
    For r = 2 To UBound(a, 1)
        For c = 1 To lastCol: out(r, c) = a(r, c): Next
        out(r, lastCol + 1) = NormKey(a(r, 1))
        out(r, lastCol + 2) = CleanEmail(CStr(a(r, 3)))
        out(r, lastCol + 3) = CleanPhone(CStr(a(r, 4)))
        out(r, lastCol + 4) = ExtractPrefecture(CStr(a(r, 5)))
    Next

    WriteBlock ws, out, outStart
    Call FormatCleaned(ws, outStart)
End Sub

Private Sub FormatCleaned(ByVal ws As Worksheet, ByVal startAddress As String)
    With ws.Range(startAddress).CurrentRegion
        .Columns.AutoFit
        .Borders.LineStyle = xlContinuous
        .Columns(.Columns.Count).NumberFormatLocal = "@" ' 住所派生は文字扱い
    End With
End Sub

Private Function ExtractPrefecture(ByVal addr As String) As String
    ' 超簡易抽出：先頭から「都/道/府/県」までを切り出し（実務は辞書で精度向上）
    Dim i As Long
    For i = 1 To Len(addr)
        Dim ch As String: ch = Mid$(addr, i, 1)
        If ch = "都" Or ch = "道" Or ch = "府" Or ch = "県" Then
            ExtractPrefecture = Left$(addr, i)
            Exit Function
        End If
    Next
    ExtractPrefecture = ""
End Function
VB

重要ポイントの深掘り

  • キー統一: CustKey（顧客IDの正規化）を作って、後続の重複処理・差分で必ず使います。
  • 連絡先の正規化: メールの大小統一、電話のハイフン除去は“同一顧客判定”に効きます。
  • 住所から都道府県抽出: 簡易なら切り出し、厳密運用は都道府県辞書を持たせると精度が上がります。

重複処理：最初／最後／項目比較で見える化と解消

重複フラグ付与（顧客ID・メール・電話で判定）

' ModCust_Duplicate.bas
Option Explicit

' 重複判定キー＝CustKey or EmailNorm or PhoneNorm のいずれか一致
Public Sub FlagDuplicates(ByVal sheetName As String, ByVal outStart As String, _
                          Optional ByVal useEmail As Boolean = True, Optional ByVal usePhone As Boolean = True)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim idxKey As Long, idxEmail As Long, idxPhone As Long
    idxKey = 1 ' A=顧客ID（Clean前でもOKだが Clean後推奨）
    idxEmail = 3: idxPhone = 4

    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary"): seen.CompareMode = 1
    Dim out() As Variant: ReDim out(1 To UBound(a, 1), 1 To 2)
    out(1, 1) = "DupFlag": out(1, 2) = "Reason"

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim reasons As String: reasons = ""
        Dim k As String: k = NormKey(a(r, idxKey))
        Dim e As String: e = CleanEmail(CStr(a(r, idxEmail)))
        Dim p As String: p = CleanPhone(CStr(a(r, idxPhone)))
        Dim probe As String: probe = k
        If useEmail And Len(e) > 0 Then probe = probe & SEP & e
        If usePhone And Len(p) > 0 Then probe = probe & SEP & p

        If seen.Exists(probe) Then
            out(r, 1) = "DUP"
            reasons = "Key/Email/Phone match"
        Else
            seen(probe) = True
            out(r, 1) = ""
        End If
        out(r, 2) = reasons
    Next
    WriteBlock Worksheets(sheetName), out, outStart
End Sub
VB

ユニーク化（最初採用・最後採用を選べる）

' 最初採用（初回を残し、以降を捨てる）
Public Sub DistinctKeepFirst(ByVal sheetName As String, ByVal outStart As String)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
    Dim out() As Variant: ReDim out(1 To 1, 1 To UBound(a, 2))
    Dim c As Long: For c = 1 To UBound(a, 2): out(1, c) = a(1, c): Next

    Dim rowsOut As Long: rowsOut = 1, r As Long
    For r = 2 To UBound(a, 1)
        Dim k As String: k = NormKey(a(r, 1))
        If Not d.Exists(k) Then
            d(k) = True
            rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To UBound(a, 2))
            For c = 1 To UBound(a, 2): out(rowsOut, c) = a(r, c): Next
        End If
    Next
    WriteBlock Worksheets(sheetName), out, outStart
End Sub

' 最後採用（同一キーの末尾を残す）
Public Sub DistinctKeepLast(ByVal sheetName As String, ByVal outStart As String)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim lastRow As Object: Set lastRow = CreateObject("Scripting.Dictionary"): lastRow.CompareMode = 1
    Dim r As Long: For r = 2 To UBound(a, 1): lastRow(NormKey(a(r, 1))) = r: Next

    Dim out() As Variant: ReDim out(1 To lastRow.Count + 1, 1 To UBound(a, 2))
    Dim c As Long: For c = 1 To UBound(a, 2): out(1, c) = a(1, c): Next
    Dim i As Long: i = 2, k As Variant
    For Each k In lastRow.Keys
        Dim rr As Long: rr = lastRow(k)
        For c = 1 To UBound(a, 2): out(i, c) = a(rr, c): Next
        i = i + 1
    Next
    WriteBlock Worksheets(sheetName), out, outStart
End Sub
VB

重要ポイントの深掘り

  • 判定軸を明確に: IDだけで足りない場合、メール・電話の正規化も組み合わせる仕様にします。
  • 採用方針の固定: 最初採用と最後採用で結果が変わるため、業務ルールを先に決め、コード名でも明示します。

差分抽出×同期：既存マスタと新規リストの更新を安全に

差分抽出（追加・削除・変更の一発判定）

' ModCust_Diff.bas
Option Explicit

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

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
End Function
VB

同期反映（丸ごと置換／差分だけ反映）

' 丸ごと置換（最も安全）
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

' 差分だけ反映（柔軟）
Public Sub SyncByApplyDiff(ByVal oldSheet As String, ByVal newSheet As String, ByVal compareColsCsv 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 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 i As Long
            For i = LBound(cmpIdx) To UBound(cmpIdx)
                If CStr(o(r, cmpIdx(i))) <> CStr(n(rr, cmpIdx(i))) Then
                    o(r, cmpIdx(i)) = n(rr, cmpIdx(i))
                End If
            Next
        Else
            Dim c As Long: For c = 1 To UBound(o, 2): o(r, c) = "": Next
        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

重要ポイントの深掘り

  • 比較列設計: 業務に効く列（氏名・メール・電話・住所など）だけを比較対象に。更新日時はノイズになりがち。
  • 同期方式: 最初は丸ごと置換で安全運用→要件が固まったら差分反映へ移行。削除の扱い（空白化／実削除）は監査要件で決めます。

出力整形・セグメント分割：営業配布と監査に使える形へ

書式整備・条件付き書式・エリア別分割

' ModCust_View.bas
Option Explicit

Public Sub FormatCustomerView(ByVal sheetName As String, ByVal startAddress As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    With ws.Range(startAddress).CurrentRegion
        .Columns.AutoFit
        .Borders.LineStyle = xlContinuous
        ' メール空欄を赤枠、電話空欄を黄枠（例）
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=LEN($C2)=0"
        .FormatConditions(1).Interior.Color = RGB(255, 230, 230)
        .FormatConditions.Add Type:=xlExpression, Formula1:="=LEN($D2)=0"
        .FormatConditions(2).Interior.Color = RGB(255, 255, 200)
    End With
End Sub

Public Sub SplitByPrefecture(ByVal sheetName As String, ByVal prefCol As Long)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim groups As Object: Set groups = CreateObject("Scripting.Dictionary"): groups.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim pref As String: pref = CStr(a(r, prefCol))
        If Len(pref) = 0 Then pref = "未分類"
        If Not groups.Exists(pref) Then
            Dim col As New Collection: col.Add r: Set groups(pref) = col
        Else
            groups(pref).Add r
        End If
    Next

    Dim k As Variant
    For Each k In groups.Keys
        Dim wsOut As Worksheet: Set wsOut = PrepareOut("Cust_" & k)
        ' ヘッダ
        wsOut.Range("A1").Resize(1, UBound(a, 2)).Value = Application.Index(a, 1)
        ' データ
        Dim col As Collection: Set col = groups(k)
        Dim i As Long
        For i = 1 To col.Count
            wsOut.Range("A" & (i + 1)).Resize(1, UBound(a, 2)).Value = Application.Index(a, col(i))
        Next
        wsOut.Columns.AutoFit
    Next
End Sub

Private Function PrepareOut(ByVal name As String) 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: ws.Name = name
    ws.Cells.Clear
    Set PrepareOut = ws
End Function
VB

重要ポイントの深掘り

  • 欠損の見える化: 連絡先欠損を色で強調し、営業やデータ管理がすぐ修正できる導線を作ります。
  • セグメント分割: 都道府県や担当者などでシート分割すると、配布・運用が楽になります。

例題の通し方：整形→重複見える化→差分抽出→同期→書式→分割

パイプライン実行例

' ModCust_Example.bas
Option Explicit

Public Sub Run_CustomerUpdate()
    ' 1) 明細整形（派生列付与）
    CleanCustomerDetail "Customer_New", "Z1"

    ' 2) 重複フラグ（ID・メール・電話）
    FlagDuplicates "Customer_New", "AA1", True, True

    ' 3) 差分抽出（氏名・メール・電話・住所を比較）
    ExtractDiff "Customer_Old", "Customer_New", "B,C,D,E", "AC1"

    ' 4) 同期（安全なら丸ごと置換、柔軟なら差分反映）
    SyncByReplace "Customer_Old", "Customer_New"
    ' SyncByApplyDiff "Customer_Old", "Customer_New", "B,C,D,E"

    ' 5) 出力整形・エリア分割
    FormatCustomerView "Customer_Old", "A1"
    SplitByPrefecture "Customer_Old", 9 ' Clean後のPrefecture列番号に合わせる
    MsgBox "顧客リスト更新パイプラインが完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

  • 派生列（CustKey/EmailNorm/PhoneNorm/Prefecture）が一括付与。
  • 重複が“DUP”で見える化され、差分が ADDED/DELETED/CHANGED の3種に分類。
  • 同期後、書式が整い、都道府県別シートが生成されます。

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

正規化不足で重複・差分が誤判定

NormKey/CleanEmail/CleanPhone を両側で適用。片側のみはヒット漏れの温床です。

比較列にノイズが混在

更新日時やメモは比較から外す。業務に意味のある属性に絞ります。

厳密な住所・都道府県判定の誤抽出

簡易抽出は便利だが、正式運用は辞書（47都道府県の完全一致・別称対応）を採用すると精度が上がります。

セル逐次書きで遅い

配列で結果を作り、一括書き戻し。十万件でもUIが固まりません。

まとめ：顧客リスト更新は「正規化→重複→差分→同期→整形→分割」の型で強くする

  • 入口で連絡先とキーを正規化し、重複と差分を一撃で見える化。
  • 同期は“丸ごと置換”で安定運用、必要に応じて“差分反映”に拡張。
  • 書式とセグメント分割まで自動化して、営業配布・監査に直結する“使えるリスト”へ。

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