会社名の名寄せ/正規化を行うExcelマクロを作ってみた

多数の企業・団体に対して営業活動をしている企業であれば、どこでも抱えている問題として、顧客企業/取引先企業の「名寄せ」をどのように行うか、ということがあります。たとえば「ABC(株)」と「ABC株式会社」は同じ会社として扱わなければならないですし、全角大文字で「ＡＢＣ（株）」と表記される場合もあります。場合によっては「エー・ビー・シー株式会社」も同じ会社名として扱わなければなりません。CRMを利用していても、この名寄せをうまくやってくれる仕組みが組み込まれていない場合が意外と多いのです。

そんな、どこの企業でも必要な変換ロジックなのですが、ネット上を探してみると、このロジックを実用的なレベルできちんと解説している情報があまりないことに気づきました。そこで、この記事では、この古くからあるニーズを、古くからあり誰でも持っているExcelマクロを使って解決する方法を紹介します。

名寄せの概要

企業・団体名の名寄せについては、以下のゆらぎへの対応を必要とします。

1. 半角/全角・大文字/小文字カナ・英数字のゆらぎ (「ＡＢＣ（株）」「ABC(株)」「abc(株)」)
2. スペース、記号の有無 (「エー・ビー・シー株式会社」「エービーシー株式会社」)
3. 前株/後株、株なし (「ABC(株)」「ABC株式会社」「株式会社ABC」「ABC」)
4. 略称・通称※ (「ABC(株)」「エービーシー株式会社」)
5. 英語表記※ (「ABC Corporation」)

最初の3つは機械的な変換ロジックで対応 (1つ目はExcelワークシート関数、2/3はVBAの置換関数) でき、※がついている最後の2つは変換テーブルを使って対応します。

準備する環境とファイル

今回はExcelマクロを使います。Excelマクロを使うと、セルの中で様々なExcelワークシート関数を用いて変換テーブルを使った変換ロジックや属性情報の追加が容易にできるためです。ただ、大して難しいことはやっていないので、ロジックさえ理解すれば他のプログラミング言語系への移植も容易に可能です。

準備するExcelのバージョンも特に選びません。VBAが使える環境であれば動作します。

以下のExcelファイル (マクロの保存が可能な*.xlsm形式または.xls形式)を準備します。

シート

• 1枚目: Main
• 2枚目: 会社名変換辞書
• 3枚目: 属性付加

"Main"シートの内容:
以下のテーブルをA4を左上角にして作成

会社名 (入力)	会社名 (規格化後)	会社名 (表記用)	担当営業	業種1	業種2

「クリア」ボタンと「マッチング開始」ボタンをヘッダー部分に配置。

"会社名変換辞書"シートの内容:
以下のテーブルをA1を左上角にして作成

変換前社名	会社名(規格化後)	会社名 (表記用)

"属性付加"シートの内容:
以下のテーブルをA1を左上角にして作成

会社名 (表記用)	担当営業	業種1	業種2

また、Visual Basic for Applications エディターを開いたときには、Clear.vbs、Start.vbsという2つの標準モジュールを用意しておきます。

ロジックの詳細

各シートの列の関係を図解すると以下のような感じです。

「規格 ("会社名(規格化後)")」の列には、機械的な変換ロジック1,2,3に基づいて規格化された文字列が格納されています。規格化された文字列には、表記用の正式会社名が紐づいており (会社名変換辞書シート) 、正式会社名には属性情報が紐づいています(属性付加シート)。これらがExcelワークシート関数を通してRDBのように紐づいて参照され、最終的な結果がMainシートに構築されます。

それではここから各ロジックの詳細を見ていきましょう。

名寄せ関数: 前株/後株の処理と仮名の規格化

変換ロジック2,3および1の一部に相当する部分は、VBAで構築します。セルの選択部分についてSubstitute関数を使って置換を行います。株式会社だけでなく様々な前株/後株表記や英語のものも置換します。カタカナの捨て仮名を通常の仮名に変換したり、中黒やハイフン、スペースといった記号を取り除いたりします。

置換を行う際は、変換する順番は気を付ける必要があります。最初に英語系の接尾語変換、次に記号、カタカナ、最後に前株、後株を変換します。また、変換する単語同士で部分文字列になっているものがある場合は、より後ろ側で部分文字列の変換を行います。

Start.vbs

'名寄せ用の変換関数
'ワークシート関数で文字列を半角/大文字に変換後、実行される
' 引数: ワークシートのlStartColumn列からlEndColumn列のlStartRow 行目から lEndRow 行目までのデータを処理する

Sub Normalize(lStartRow As Long, lEndRow As Long, lStartColumn As Long, lEndColumn As Long)

On Error Resume Next


    Range(Cells(lStartRow, lStartColumn), Cells(lEndRow, lEndColumn)).Select

    With Selection
        ' 英語の後株文字列を削除
        .Value = Application.Substitute(Selection, "_JAPAN", "")
        .Value = Application.Substitute(Selection, " - JAPAN", "")
        .Value = Application.Substitute(Selection, " CORPORATION", "")
        .Value = Application.Substitute(Selection, " CORP", "")
        .Value = Application.Substitute(Selection, " KK", "")
        .Value = Application.Substitute(Selection, " K.K.", "")
        .Value = Application.Substitute(Selection, " CO.,LTD", "")
        .Value = Application.Substitute(Selection, " CO., LTD", "")
        .Value = Application.Substitute(Selection, " CO.,INC.", "")
        .Value = Application.Substitute(Selection, " CO., INC.", "")
        .Value = Application.Substitute(Selection, " LLC", "")
        .Value = Application.Substitute(Selection, " LTD", "")
        .Value = Application.Substitute(Selection, " INC", "")

        ' スペースの変換
        .Value = Application.Substitute(Selection, " ", "")

        ' 記号の削除
        .Value = Application.Substitute(Selection, "-", "")
        .Value = Application.Substitute(Selection, "_", "")
        .Value = Application.Substitute(Selection, ".", "")
        .Value = Application.Substitute(Selection, ",", "")
        .Value = Application.Substitute(Selection, "・", "")
        .Value = Application.Substitute(Selection, "･", "")
        .Value = Application.Substitute(Selection, "/", "")

        ' カタカナを小文字⇒大文字
        .Value = Application.Substitute(Selection, "ｬ", "ﾔ")
        .Value = Application.Substitute(Selection, "ｭ", "ﾕ")
        .Value = Application.Substitute(Selection, "ｮ", "ﾖ")
        .Value = Application.Substitute(Selection, "ｯ", "ﾂ")
        .Value = Application.Substitute(Selection, "ｧ", "ｱ")
        .Value = Application.Substitute(Selection, "ｨ", "ｲ")
        .Value = Application.Substitute(Selection, "ｩ", "ｳ")
        .Value = Application.Substitute(Selection, "ｪ", "ｴ")
        .Value = Application.Substitute(Selection, "ｫ", "ｵ")
        .Value = Application.Substitute(Selection, "ヴ", "ｳﾞ")

        ' 以後は日本語の前株後株文字列を削除
        .Value = Application.Substitute(Selection, "株式会社", "")
        .Value = Application.Substitute(Selection, "(株)", "")
        .Value = Application.Substitute(Selection, "㈱", "")
        .Value = Application.Substitute(Selection, "(有)", "")
        .Value = Application.Substitute(Selection, "（有）", "")
        .Value = Application.Substitute(Selection, "有限会社", "")
        .Value = Application.Substitute(Selection, "㈲", "")
        .Value = Application.Substitute(Selection, "(財)", "")
        .Value = Application.Substitute(Selection, "(一財)", "")
        .Value = Application.Substitute(Selection, "(公財)", "")
        .Value = Application.Substitute(Selection, "一般財団法人", "")
        .Value = Application.Substitute(Selection, "公益財団法人", "")
        .Value = Application.Substitute(Selection, "財団法人", "")
        .Value = Application.Substitute(Selection, "(資)", "")
        .Value = Application.Substitute(Selection, "合資会社", "")
        .Value = Application.Substitute(Selection, "合同会社", "")
        .Value = Application.Substitute(Selection, "(同)", "")
        .Value = Application.Substitute(Selection, "(合)", "")
        .Value = Application.Substitute(Selection, "宗教法人", "")
        .Value = Application.Substitute(Selection, "(宗)", "")
        .Value = Application.Substitute(Selection, "一般社団法人", "")
        .Value = Application.Substitute(Selection, "公益社団法人", "")
        .Value = Application.Substitute(Selection, "社団法人", "")
        .Value = Application.Substitute(Selection, "(社)", "")
        .Value = Application.Substitute(Selection, "(一社)", "")
        .Value = Application.Substitute(Selection, "(公社)", "")
        .Value = Application.Substitute(Selection, "社会福祉法人", "")
        .Value = Application.Substitute(Selection, "(社福)", "")
        .Value = Application.Substitute(Selection, "独立行政法人", "")
        .Value = Application.Substitute(Selection, "(独)", "")
        .Value = Application.Substitute(Selection, "特定非営利活動法人", "")
        .Value = Application.Substitute(Selection, "(特)", "")
        .Value = Application.Substitute(Selection, "(特定)", "")
        .Value = Application.Substitute(Selection, "学校法人", "")
        .Value = Application.Substitute(Selection, "(学)", "")
        .Value = Application.Substitute(Selection, "医療法人", "")
        .Value = Application.Substitute(Selection, "(医)", "")
    End With

End Sub

会社名変換辞書の参照と属性テーブルからのデータ追加

次にロジックのメインになる部分をExcel VBAで記載します。このStartサブルーチンはStart.vbsの先頭に配置してください。また、Mainシートの「マッチング開始」ボタンから呼び出すようにしてください。

Start.vbs

Sub Start()

    Dim lStartRow As Long, lEndRow As Long, lConvRow As Long, lDataRow As Long, lDataCol As Long


    lStartRow = 5                                           '会社名データが始まる行
    lEndRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row  'A列データ最下行を検索

    If lEndRow < lStartRow Then                             'データが貼り付けられていなければ処理中止
        MsgBox "会社名がA列に貼り付けられていません。処理を中止します。", vbOKOnly, "要確認"
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False                             '画面更新中断
        .StatusBar = "処理中です......"                     'ステータスバー表示
    End With

    Range(Cells(lStartRow, 2), Cells(Rows.Count, Columns.Count)).ClearContents  'データクリア


    lConvRow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row    '会社名変換辞書の最終行設定
    lDataRow = Sheets(3).Cells(Rows.Count, 1).End(xlUp).Row    '属性付加の最終行設定
    lDataCol = Sheets(3).Cells(1, Columns.Count).End(xlToLeft).Column '属性付加の最終列設定


    ''''' B 列の作成
    With Range(Cells(lStartRow, 2), Cells(lEndRow, 2))      'まず名寄せ用数式をB列に投入
        .Value = "=UPPER(ASC(TRIM(CLEAN(SUBSTITUTE(A" + Format(lStartRow) + ",CHAR(160),"" "")))))"
        .Copy
        .PasteSpecial xlPasteValues                         'コピーして値貼付
    End With

    Call Normalize(lStartRow, lEndRow, 2, 2)                '名寄せ変換マクロ実行


    ''''' C 列の作成
    With Range(Cells(lStartRow, 3), Cells(lEndRow, 3))
        .Value = "=IFNA(VLOOKUP(B" + Format(lStartRow) + "," + Sheets(2).Name + "!$B$2:$C$" + Format(lConvRow) + ",2,FALSE),A" + Format(lStartRow) + ")"
        .Copy
        .PasteSpecial xlPasteValues                         'コピーして値貼付
    End With


    ''''' D 列以降の作成
    With Range(Cells(lStartRow, 4), Cells(lEndRow, lDataCol + 2))
        .Value = "=IFNA(VLOOKUP($C" + Format(lStartRow) + "," + Sheets(3).Name + "!$A$2:$" + ConvertToLetter(lDataCol + 2) + "$" + Format(lDataRow) + ",COLUMN()-2,FALSE),"""")"
        .Copy
        .PasteSpecial xlPasteValues                         'コピーして値貼付
    End With



    ' 会社名変換辞書/属性追加に空欄がある場合、"0"を空白に置換
    Range(Cells(lStartRow, 3), Cells(lEndRow, lDataCol + 2)).Replace What:="0", Replacement:="", LookAt:=xlWhole, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


    Application.CutCopyMode = False                         ' 選択モード解除
    Range("A" + Format(lStartRow)).Select

    With Application
        .ScreenUpdating = True                              '画面更新開始
        .StatusBar = ""
    End With
    MsgBox "処理終了"


End Sub

やっていること

• 最初にMainシートのB列以降のコンテンツ範囲を自動検出、選択して中身を消去します。
• B列のコンテンツをExcelワークシート関数を使って作成、その後「値の貼り付け」を行い関数自体は見えないようにします。
  例:=UPPER(ASC(TRIM(CLEAN(SUBSTITUTE(A5,CHAR(160),"" "")
• B列のコンテンツに対して名寄せ関数を実行します。
• C列のコンテンツをExcelワークシート関数を使って作成、その後「値の貼り付け」を行い関数自体は見えないようにします。
  例:=IFNA(VLOOKUP(B5,会社名変換辞書!$B$2:$C$300,2,FALSE),A5)
• D列以降のコンテンツをExcelワークシート関数を使って作成、その後「値の貼り付け」を行い関数自体は見えないようにします。
  例:=IFNA(VLOOKUP($C5,属性付加!$A$2:$G$300,COLUMN()-2,FALSE),"")
• 会社名変換辞書/属性付加テーブルに参照先がなかった場合は、セルの値が「0」になる場合があるので、その文字列を削除します。

B列、C列、およびD列以降のセルのコンテンツをExcelワークシート関数を使って処理している箇所ですが、共通の "あるテクニック" を使っています。いずれもRangeオブジェクトで指定されたセル範囲の複数セルに関数式を書き込んでいますが、セルの相対参照になっている部分は「セルの位置がずれるごとにずれた参照がされる」ようになっています。たとえば、=IFNA(VLOOKUP($C5,属性付加!$A$2:$G$300,COLUMN()-2,FALSE),"")は、緑色の部分が絶対参照、赤色の部分が相対参照になっています。

=IFNA(VLOOKUP(\$C5,属性付加!\$A\$2:\$G\$300,COLUMN()-2,FALSE),"")

この式を簡略化して "=FUNC(5,2)" (D列の場合、Column()-2は4-2=2となるので)、相対参照の部分だけ抜き出すと、実際には以下のような参照となります。このように、

	A	B	C	D	E	F	G
4
5				=FUNC(5,2)	=FUNC(5,3)	=FUNC(5,4)	=FUNC(5,5)
6				=FUNC(6,2)	=FUNC(6,3)	=FUNC(6,4)	=FUNC(6,5)
7				=FUNC(7,2)	=FUNC(7,3)	=FUNC(7,4)	=FUNC(7,5)

このように、Rangeオブジェクトを使ってセルの値を代入すると、セルの相対参照を利用することでExcelワークシート関数を使った範囲参照を簡単な手順で行うことが可能になります。

ちなみに、属性追加シートに保管している属性データですが、列を追加してより多くの属性を格納することもできます。列を追加した場合にもコードは対応しており、変更の必要がありません。

制限事項: 同名の会社名の仕分け (前株/後株や表記が違う場合もある) には対応していません。

便利なサブルーチン: Excelの列番号をR1C1形式からA1形式に変換

Excel VBAを組んでいる際に、よく欲しくなるのが列番号をR1C1形式からA1形式に変換するロジックです。たとえば15番目の列はJ、30番目の列はADという具合です。このロジックは『Excel の列番号を英文字に変換する方法 - Microsoft Docs』でVisual Basicの実装として公開されているので、このConvertToLetter関数を先のStartサブルーチン中でも使います。

Start.vbs

' Excel の列番号を英文字に変換する
Function ConvertToLetter(iCol As Integer) As String
   Dim iAlpha As Integer
   Dim iRemainder As Integer
   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ConvertToLetter = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
   End If
End Function

シートのクリア

最後にMainシートの「クリア」ボタンから呼び出す、Mainシートのデータ全消去の実装を作成します。Clear.vbsの先頭に以下のClearサブルーチンを配置します。

Clear.vbs

Sub Clear()
   Dim lStartRow As Long

   lStartRow = 5 '会社名データが始まる行

   If Worksheets(1).FilterMode = True Then
        Worksheets(1).ShowAllData
   End If

   Range(Cells(lStartRow, 1), Cells(Rows.Count, Columns.Count)).ClearContents
   Range("A" & lStartRow).Select

End Sub

Mainシートの中で、5行目以降でデータが入っている箇所を自動的に検出、選択して中身を消去します。

これですべての実装が完了しました！

最後に

Excel VBAを使った名寄せはわりとシンプルに実装できました。日々の業務で活用いただければうれしいです！
それではまた！('ω')ノ