Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – 名寄せテンプレ

Excel VBA
スポンサーリンク

ねらい：名寄せ（同一人物・同一企業の突合せ）を「正規化→判定→スコア→統合」の型で安全に回す

名寄せは「表記ゆれ・略称・住所の揺れ」を潰し、重複候補を拾い、確信度でランク分けして、統合ルール（どの列を残すか）に従って1件へまとめる作業です。配列I/O＋Dictionary＋正規化＋スコアリングで“速く・壊れない”名寄せパイプラインを作り、初心者でも貼って動くテンプレを例題付きで解説します。

共通基盤：配列I/O・正規化・簡易距離関数

一括読み書き・正規化ユーティリティ

' ModNayo_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 NormText(ByVal s As Variant) As String
    Dim t As String: t = LCase$(Trim$(CStr(s)))
    t = Replace(t, "　", "")      ' 全角空白除去
    t = Replace(t, " ", "")       ' 半角空白除去
    t = Replace(t, "-", "")       ' - を除去（電話など）
    t = Replace(t, "－", "")      ' 全角-
    NormText = t
End Function

Public Function NormCompany(ByVal s As Variant) As String
    Dim t As String: t = LCase$(Trim$(CStr(s)))
    t = Replace(t, "株式会社", "")
    t = Replace(t, "（株）", "")
    t = Replace(t, "(株)", "")
    t = Replace(t, "有限会社", "")
    t = Replace(t, "合資会社", "")
    t = Replace(t, "合同会社", "")
    t = Replace(t, "　", ""): t = Replace(t, " ", "")
    NormCompany = t
End Function

Public Function NormAddress(ByVal s As Variant) As String
    Dim t As String: t = LCase$(Trim$(CStr(s)))
    t = Replace(t, "　", ""): t = Replace(t, " ", "")
    t = Replace(t, "丁目", "-")
    t = Replace(t, "番地", "-")
    t = Replace(t, "−", "-"): t = Replace(t, "ー", "-")
    NormAddress = t
End Function

Public Function NormPhone(ByVal s As Variant) As String
    Dim t As String: t = LCase$(Trim$(CStr(s)))
    t = Replace(t, "-", ""): t = Replace(t, " ", ""): t = Replace(t, "　", "")
    NormPhone = t
End Function

Public Function NormEmail(ByVal s As Variant) As String
    NormEmail = LCase$(Trim$(CStr(s)))
End Function
VB

簡易レーベンシュタイン距離（文字列類似度）

' 小型・十分速い文字列距離。短文の氏名・会社名・住所ブロック向け
Public Function EditDistance(ByVal a As String, ByVal b As String) As Long
    Dim la As Long: la = Len(a)
    Dim lb As Long: lb = Len(b)
    Dim i As Long, j As Long
    Dim dp() As Long: ReDim dp(0 To la, 0 To lb)
    For i = 0 To la: dp(i, 0) = i: Next
    For j = 0 To lb: dp(0, j) = j: Next
    For i = 1 To la
        For j = 1 To lb
            Dim cost As Long: cost = IIf(Mid$(a, i, 1) = Mid$(b, j, 1), 0, 1)
            dp(i, j) = WorksheetFunction.Min(dp(i - 1, j) + 1, dp(i, j - 1) + 1, dp(i - 1, j - 1) + cost)
        Next
    Next
    EditDistance = dp(la, lb)
End Function

Public Function SimilarityScore01(ByVal a As String, ByVal b As String) As Double
    If Len(a) = 0 And Len(b) = 0 Then SimilarityScore01 = 1#: Exit Function
    Dim d As Long: d = EditDistance(a, b)
    Dim m As Long: m = WorksheetFunction.Max(Len(a), Len(b))
    SimilarityScore01 = 1# - (d / m) ' 0〜1（1が完全一致）
End Function
VB

重要ポイントの深掘り

  • 正規化は“名寄せの入口”。会社名の法人格除去、住所の地番表記統一、電話・メールの揺れ潰しを必ず通します。
  • 距離関数は「似ている」を数値化します。距離→類似度（0〜1）に換算して閾値で判定するのが扱いやすいです。

候補抽出：キーと近傍フィルタで対象を絞る

ブロッキング（候補集合の高速絞り込み）

' ModNayo_Block.bas
Option Explicit

' Data: A=顧客ID, B=氏名, C=会社名, D=住所, E=電話, F=メール
' BlockKey = 会社名の先頭3文字＋住所の郵便番号先頭3文字など、軽い近傍キー
Public Sub BuildBlocks(ByVal sheetName As String, ByVal outStart As String, Optional ByVal prefixLen As Long = 3)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim blocks As Object: Set blocks = CreateObject("Scripting.Dictionary"): blocks.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim comp As String: comp = NormCompany(a(r, 3))
        Dim addr As String: addr = NormAddress(a(r, 4))
        Dim key As String: key = Left$(comp, prefixLen) & SEP & Left$(addr, prefixLen)
        If Not blocks.Exists(key) Then
            Dim col As New Collection: col.Add r: Set blocks(key) = col
        Else
            blocks(key).Add r
        End If
    Next

    ' 出力：BlockKey, Count, Rows
    Dim out() As Variant: ReDim out(1 To 1, 1 To 3)
    out(1, 1) = "BlockKey": out(1, 2) = "Count": out(1, 3) = "Rows"
    Dim rowsOut As Long: rowsOut = 1
    Dim k As Variant
    For Each k In blocks.Keys
        Dim col As Collection: Set col = blocks(k)
        If col.Count > 1 Then
            rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 3)
            out(rowsOut, 1) = k
            out(rowsOut, 2) = col.Count
            out(rowsOut, 3) = Join(CollectionToArray(col), ",")
        End If
    Next
    WriteBlock Worksheets(sheetName), out, outStart
End Sub

Private Function CollectionToArray(ByVal col As Collection) As String()
    Dim i As Long, arr() As String: ReDim arr(0 To col.Count - 1)
    For i = 1 To col.Count: arr(i - 1) = CStr(col(i)): Next
    CollectionToArray = arr
End Function
VB

重要ポイントの深掘り

  • 「ブロッキング」は名寄せのスピードの鍵。似ている可能性が高いレコードを狭い集合に絞ってから重い判定をかけます。
  • 会社名の先頭・住所の先頭・郵便番号など、現場に合う近傍キーを設計しましょう。

スコアリング：複数属性を点数化して確信度を出す

氏名・会社名・住所・電話・メールの合成スコア

' ModNayo_Score.bas
Option Explicit

' 各属性の重みを調整可能（総合スコア 0〜1）
Public Function MatchScore(ByVal nameA As String, ByVal nameB As String, _
                           ByVal compA As String, ByVal compB As String, _
                           ByVal addrA As String, ByVal addrB As String, _
                           ByVal phoneA As String, ByVal phoneB As String, _
                           ByVal emailA As String, ByVal emailB As String) As Double
    Dim sName As Double: sName = SimilarityScore01(NormText(nameA), NormText(nameB))
    Dim sComp As Double: sComp = SimilarityScore01(NormCompany(compA), NormCompany(compB))
    Dim sAddr As Double: sAddr = SimilarityScore01(NormAddress(addrA), NormAddress(addrB))
    Dim sPhone As Double: sPhone = IIf(Len(NormPhone(phoneA)) > 0 And NormPhone(phoneA) = NormPhone(phoneB), 1#, 0#)
    Dim sMail As Double: sMail = IIf(Len(NormEmail(emailA)) > 0 And NormEmail(emailA) = NormEmail(emailB), 1#, 0#)

    ' 重み（例）：会社名0.35、住所0.25、氏名0.2、電話0.1、メール0.1
    MatchScore = 0.35 * sComp + 0.25 * sAddr + 0.2 * sName + 0.1 * sPhone + 0.1 * sMail
End Function
VB

重要ポイントの深掘り

  • 属性ごとに“似ている”度合いを計算し、重み付きで合成します。会社名・住所に重みを置くと法人名寄せが安定します。
  • 電話・メールは一致なら満点、欠損なら0扱い。欠損が多い現場は重みを下げるか、補助スコアにします。

重複候補の抽出：閾値でランク分けしてレビュー導線を作る

候補一覧の生成（High/Medium/Lowの3段階）

' ModNayo_Candidates.bas
Option Explicit

' inSheet: 元データ、outStart: 出力先開始セル
' thrHigh/Medium: 閾値（例：0.85/0.7）
Public Sub ListDuplicateCandidates(ByVal inSheet As String, ByVal outStart As String, _
                                   Optional ByVal thrHigh As Double = 0.85, Optional ByVal thrMedium As Double = 0.7)
    Dim a As Variant: a = ReadRegion(Worksheets(inSheet))
    Dim out() As Variant: ReDim out(1 To 1, 1 To 7)
    out(1, 1) = "RowA": out(1, 2) = "RowB": out(1, 3) = "Score": out(1, 4) = "Rank"
    out(1, 5) = "NameA|NameB": out(1, 6) = "CompA|CompB": out(1, 7) = "AddrA|AddrB"

    Dim rowsOut As Long: rowsOut = 1
    Dim i As Long, j As Long
    For i = 2 To UBound(a, 1) - 1
        For j = i + 1 To UBound(a, 1)
            ' 同一ブロックのみ比較に絞るならブロッキングキーの一致でフィルタ（省略例）
            Dim sc As Double
            sc = MatchScore(a(i, 2), a(j, 2), a(i, 3), a(j, 3), a(i, 4), a(j, 4), a(i, 5), a(j, 5), a(i, 6), a(j, 6))
            If sc >= thrMedium Then
                rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 7)
                out(rowsOut, 1) = i
                out(rowsOut, 2) = j
                out(rowsOut, 3) = sc
                out(rowsOut, 4) = IIf(sc >= thrHigh, "HIGH", "MEDIUM")
                out(rowsOut, 5) = a(i, 2) & " | " & a(j, 2)
                out(rowsOut, 6) = a(i, 3) & " | " & a(j, 3)
                out(rowsOut, 7) = a(i, 4) & " | " & a(j, 4)
            End If
        Next
    Next
    WriteBlock Worksheets(inSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • スコアが高いものを「HIGH」、中程度を「MEDIUM」としてレビュー対象に。低スコアは無視して作業効率を上げます。
  • 実運用では必ず「ブロッキング」で組合せ数を減らしてから比較します（全組合せは大規模データで非現実的）。

統合（サバイバーシップ）：どの列を残すかのルール化

統合ルール例（最新・非空優先・長さ優先）

' ModNayo_Merge.bas
Option Explicit

' 同一人物/企業と判定された2行を統合し、1行にまとめる
' ルール例：最新登録日優先、非空優先、文字列は長い方優先、電話・メールは正規化一致ならどちらでも
Public Sub MergePair(ByVal ws As Worksheet, ByVal rowA As Long, ByVal rowB As Long, ByVal outStart As String)
    Dim a As Variant: a = ws.Range("A1").CurrentRegion.Value
    Dim out() As Variant: ReDim out(1 To 2, 1 To UBound(a, 2))
    Dim c As Long
    ' ヘッダ
    For c = 1 To UBound(a, 2): out(1, c) = a(1, c): Next
    ' 結果行
    For c = 1 To UBound(a, 2)
        Dim vA As String: vA = CStr(a(rowA, c))
        Dim vB As String: vB = CStr(a(rowB, c))
        Dim pick As String: pick = vA
        If Len(vB) > 0 And Len(vA) = 0 Then pick = vB
        If Len(vB) > Len(vA) Then pick = vB
        ' 登録日列（例：F列=6）は新しい方
        If c = 6 Then
            If IsDate(a(rowA, c)) And IsDate(a(rowB, c)) Then
                pick = IIf(CDate(a(rowA, c)) >= CDate(a(rowB, c)), CStr(a(rowA, c)), CStr(a(rowB, c)))
            End If
        End If
        out(2, c) = pick
    Next
    WriteBlock ws, out, outStart
End Sub
VB

重要ポイントの深掘り

  • 統合ルール（サバイバーシップ）は現場で必ず合意する項目。最新日付、非空優先、文字列は長い方が情報量が多い、などの原則を決めておきます。
  • 片側が空ならもう片側を採用、両方値ありなら“優先基準”で決める、という順序にすると安定します。

例題の通し方：ブロック→候補抽出→統合→名寄せ済みリスト出力

パイプライン実行例（氏名・会社・住所・電話・メール）

' ModNayo_Example.bas
Option Explicit

Public Sub Run_NayosePipeline()
    ' 1) ブロッキング（会社名・住所の先頭で近傍キー）
    BuildBlocks "Customers", "Z1", 3

    ' 2) 候補抽出（スコア 0.85/0.7でHIGH/MEDIUM）
    ListDuplicateCandidates "Customers", "AA1", 0.85, 0.7

    ' 3) 統合（例：候補一覧から手動で RowA/RowB を選んで実行していく）
    '    ここでは例として 10行目と11行目を統合
    MergePair Worksheets("Customers"), 10, 11, "AC1"

    MsgBox "名寄せパイプラインの候補抽出と統合例が完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

  • ブロック一覧で“似ている集合”が見える化。
  • 候補抽出にスコアとランクが出て、レビューの焦点が絞れる。
  • 統合結果がヘッダ付きで1行にまとまり、統合ルールが反映されている。

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

正規化不足で候補漏れ・誤判定

会社法人格の残り、住所の表記差、電話のハイフン混在などは必ず前処理で統一します。NormCompany/NormAddress/NormPhone/NormEmailを両側で適用。

全組合せ比較で遅すぎる

「ブロッキング」で集合を絞った上でスコアリングします。近傍キーの設計（先頭一致、郵便番号、都道府県＋市区など）が速度の鍵です。

スコア閾値の誤設定

高すぎると見逃し、低すぎるとノイズだらけ。まずは“HIGH=0.85、MEDIUM=0.7”で始め、現場の誤検知率を見ながら調整します。

統合ルールが曖昧で現場が迷う

「最新・非空・長さ優先」を柱に、列ごとの特則（住所は長い方、電話は正規化一致優先など）をドキュメント化します。

セル逐次書きで遅い・固まる

結果は配列で作り、一括書き戻し。10万件でもUIが安定し、毎日回せます。

まとめ：名寄せは「正規化→ブロッキング→スコア→統合」の型で速く・堅牢に

入口で揺れを潰し、候補集合を賢く絞り、重み付きスコアでランク分け、合意済みの統合ルールで1件へ。配列I/O＋Dictionary＋距離関数の組み合わせで、規模が大きくても壊れない名寄せ運用が実現します。

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