Excel VBA 大量データの部分一致検索

Question

前提・実現したいこと

VBAで大量データの一部一致検索を行いたいです。
処理件数が多く、どのように処理すればいいか分からず、悩んでいます。

１：列Aのキーワードを元に列B内を検索。
２：”部分一致”すれば、列Cに部分一致したデータ(列Bの値）を全てカンマ区切りで出力します。
３：それ以外は　NA　を列Cへ出力します。

【データサンプル↓】プログラム実行前

列A（100万行rawdata）　　｜　　　列B（20万行rawdata）　　　　｜　　列C（空白）
アイス　　　　　　　 　 たまごっち２　　　　　　　　　　
たまごっち　　　　　 　　　 アイス　　　　　　　　　　　　　　
ほげほげランド　　　　　　　　　お茶　　　　　　　　　　　　　　　　
ほげほげマウス　　　　　　　　　ほげほげランドスーパー
綾鷹　　　　　　　　　　　　　　ほげほげランドエクストラ　　　　　　
・・・　　　　　　　　　　　　　・・・　　　　　　　　　　　　　　
・・　　　　　　　　　　　　　　・・　　　　　　　　　　　　　　　　

【データサンプル↓】プログラム実行後

列A（100万行rawdata）　　｜　　　列B（20万行rawdata）　｜　列C（出力結果）
アイス　　　　　　　 　 たまごっち２　　　　　　　　アイス
たまごっち　　　　　 　　　 アイス　　　　　　　　　　　たまごっち２
ほげほげランド　　　　　　　　　お茶　　　　　　　　　　　　ほげほげランドスーパー,ほげほげランドエクストラ
ほげほげマウス　　　　　　　　　ほげほげランドスーパー NA
綾鷹　　　　　　　　　　　　　　ほげほげランドエクストラ　　NA
・・・　　　　　　　　　　　　　・・・　　　　　　　　　　　・・・
・・　　　　　　　　　　　　　　・・　　　　　　　　　　　　・・
・　　　　　　　　　　　　　　　・　　　　　　　　　　　　　・

発生している問題・エラーメッセージ

データが膨大な為、単純にループすると処理が終わりません（１０４８５７６行×２０万行）。
Dictionaryを使う方法では完全一致検索しかできませんでした。

試したこと

https://officedic.com/excel-vba-highspeed-find/
こちらのサイトのDictionaryを使用した方法で、”完全一致”は出来ました。
（VBA running time は大体15秒くらいでした）

補足情報（FW/ツールのバージョンなど）

Excel2019

Comments

[jinoji]

列C（出力結果）の２行目は「たまごっち２」となるのではないですか？

[takoasi]

その通りです。
すみません、修正いたしました。

Answer 1

B列の単語を全部1つの文字列変数に入れて検索するというのはどうでしょうか?
VBAの制限は20億文字らしいので、20万件なら納まるかと思います。

単語長によってかなり変わるとは思いますが、とりあえずB列=20万件、A列=1万件で
やってみて約100秒でした。

Private Sub test()
  '
  ' B列を文字列変数にコピー
  ' ※単語間の区切り記号はVbLf
  ' ※TextJoinが使えるならそれでもよい
  '
  Me.Range("B1:B200000").Copy
  Dim CB As New DataObject
  CB.GetFromClipboard
  If (Not CB.GetFormat(1)) Then Exit Sub
  
  Dim cmp As String: cmp = vbLf & CB.GetText & vbLf
  Set CB = Nothing
  Application.CutCopyMode = False
  '
  ' 検索
  '
  Dim wx As Long
  For wx = 1 To 10000
    Dim key As String: key = Me.Cells(wx, "A").Value
    Dim txt As String: txt = ""
    Dim ix As Long: ix = InStr(cmp, key)
    If (ix > 0) Then
      Do
        '
        ' 検出した位置の直前のLF～直後LFの間が求める単語
        '
        Dim sx As Long: sx = InStrRev(cmp, vbLf, ix) + 1
        txt = txt & "," & Mid$(cmp, sx, InStr(ix, cmp, vbLf) - sx)
        ix = InStr(ix + 1, cmp, key)
      Loop While ix > 0
      txt = Mid$(txt, 2)    ' 先頭コンマを除く
    Else
      txt = "NA"
    End If
    
    Me.Cells(wx, "C") = txt
    
    If ((wx Mod 1000) = 0) Then Application.StatusBar = wx
  Next wx
  
End Sub
コード

Comments

[takoasi]

ご回答ありがとうございます！
こういうやり方もあるのですね('ω')

数時間かけたら処理できそうです。いまから試します。

Answer 2

試しにこんな感じで書いてみましたが、やはり大量データだと厳しいですね。

Sub Sample()

    Dim ws As Worksheet
    Dim lastA As Long, lastB As Long
    Dim arrA As Variant, arrB As Variant
    Dim i As Long

    Set ws = ThisWorkbook.Worksheets(1)
    lastA = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    lastB = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    
    arrA = ws.Columns(1).Resize(lastA).Value
    arrB = ws.Columns(2).Resize(lastB).Value
    
    With New Scripting.Dictionary
        For i = 1 To lastB
            .Item(arrB(i, 1)) = 0
        Next
        arrB = .Keys
    End With
    
    For i = 1 To lastA
        arrA(i, 1) = Join(Filter(arrB, arrA(i, 1)), ",")
        If arrA(i, 1) = "" Then arrA(i, 1) = "NA"
    Next
    
    For i = 1 To lastA
        ws.Range("C" & i).Value = arrA(i, 1)
    Next

End Sub

Comments

[hatena19]

私もFilter関数を使ったコードも書いてみたのですが、単純なループより遅かったです。
部分一致で高速化は難しいですね。

[jinoji]

もともとFilter関数って結構遅いイメージがあります。
ただ、B列の行数が大量になると こちらの方が速くなる場合もあるみたいです。
（データの中身にもよるのかもしれませんが。）

[takoasi]

アルゴリズムから考えるか、
データベースを使用してみようと思います。
ご回答ありがとうございます！

[hatena19]

データベースを利用しても部分一致では難しいでしょうね。
データベースはインデックスを利用して検索等を高速処理してますが、部分一致では利用できませんので。
グーグルなどのWEB検索では、事前にサイトからキーワードを取り出してインデックスにするなどのテクニックを使っています。
「全文検索エンジン」でWEB検索してみるといいかもしれません。

[takoasi]

DBでも難しいですか。
「全文検索エンジン」検索してみます、
ありがとうございます。

[hatena19]

DBによっては全文検索機能を持っているものをあるようです。
例えばMySQLとか。

Answer 3

A列とB列をそれぞれ配列に入れて、2重ループで部分一致を検索する。
結果も配列に出力して、最後に結果配列をシートに出力ということになると思います。

エクセルで遅くなる原因はセルへの参照、更新ですので、それをなるべく少なくするという方針でいくのがいいでしょう。

Public Sub Sample()
    Dim A(), B(), C() As String
    Dim ACnt As Long, BCnt As Long
    ACnt = Cells(Rows.Count, 1).End(xlUp).Row
    A = Cells(1, 1).Resize(ACnt).Value
    BCnt = Cells(Rows.Count, 2).End(xlUp).Row
    B = Cells(1, 2).Resize(BCnt).Value
    ReDim C(1 To ACnt, 1 To 1)
    
    Dim i As Long, j As Long
    For i = 1 To ACnt
        For j = 1 To BCnt
            If InStr(1, B(j, 1), A(i, 1), vbBinaryCompare) > 0 Then
                C(i, 1) = C(i, 1) & "," & B(j, 1)
            End If
        Next
    Next
    For i = 1 To ACnt
        If C(i, 1) = "" Then
            C(i, 1) = "NA"
        Else
           C(i, 1) = Mid(C(i, 1), 2)
        End If
    Next
    
    Cells(1, 3).Resize(ACnt).Value = C
End Sub

100万×20万のサンプルデータを作成して上記のコードを実行してみたら、数十分たっても終わらないです。
これだけのループになるとさすがに配列でも苦しいですね。
1万×1万のデータで9秒ぐらいでした。

Comments

[takoasi]

ご回答ありがとうございます。
そうですねぇ、配列をループするのも苦しいので、２分岐探索とかDictionaryとかなんか使わないといけないのかな？と素人ながらに思ったものの、その方法が良く分からなくて困っていまして。。

[takoasi]

サンプルデータ作成までして頂いて本当にありがとうございます。