二つのリストを比べて部分一致する際に一致する文字列を抽出するVBA

いつもお世話になっております。
他の質問者様への回答より（https://oshiete.goo.ne.jp/qa/10889530.html）
上記参考に参照部分変えて作成してみたのですが、抽出場所と範囲が異なる為か、上手く動かず
また通常のループ処理だとデータが重いのか固まってしまいます。
二つのリストを比べて部分一致するものを隣の列に抽出したいです。
どうにか助けて頂けないでしょうか。

SHEET1⇒大元のデータ　3万件程
SHEET2⇒検索文字　　　3千件程

SHEET2のD列には抽出したい項目があります。（途中空白も含まれます）
そこでSHEET1のW列の中にSHEET2のA列の文字が含まれているとき、
SHEET1のX列2行目以降に一致した部分だけデータを抽出できないでしょうか。

SHEET1 ("作業用"）
～（W列）　　　　（X列）
企業名　　　　　　企業名
A㈱**　　　　　　　A㈱
*B㈱***　　　　　 B㈱
C㈱**
**D㈱**** D㈱

SHEET2("企業名修正")
企業名
A㈱
B㈱
D㈱

No.1 ベストアンサー 回答者： fujillin 回答日時： 2021/04/28 11:44

こんにちは

過去の質疑はみていませんので、ご質問文からだけですけれど・・・

＞SHEET2のD列には抽出したい項目があります。
＞～SHEET2のA列の文字が含まれているとき、～
など、不明点がありますが、テキトーに仮定しました。

・シート名は「Sheet1」と「Sheet2」であるものと仮定。
・両シートとも1行目はタイトル行で、2行目からがデータであると仮定。
・検索キーに当たる文字列群は、Sheet2のA列に存在すると仮定。
・複数のキーワードがヒットすることは無いものと仮定。
　（1件ヒットした時点で打ち切っています ＝ 速度向上のため）

※ 以下は、全データをまとめて読み込んで処理する例ですので、メモリの使用量は増加します。
※ もしも、メモリ不足の場合は、一定単位（1万件や5千件など）ごとに順に処理をするように変更すればよろしいと思います。

ご参考までに。

Sub Sample_12331339()
Dim s1, s2
Dim n1 As Long, n2 As Long
Dim s As String, i As Long, j As Long

With Worksheets("Sheet2")
　n2 = .Cells(Rows.Count, 1).End(xlUp).Row - 1
　If n2 < 1 Then Exit Sub
　s2 = .Cells(2, 1).Resize(n2).Value
　For j = 1 To n2
　　If s2(j, 1) = "" Then s2(j, 1) = Chr(27)
　Next j
End With

With Worksheets("Sheet1")
　n1 = .Cells(Rows.Count, 23).End(xlUp).Row - 1
　If n1 < 1 Then Exit Sub
　s1 = .Cells(2, 23).Resize(n1).Value

　For i = 1 To n1
　　s = s1(i, 1)
　　s1(i, 1) = ""
　　For j = 1 To n2
　　　If InStr(s, s2(j, 1)) > 0 Then
　　　　s1(i, 1) = s2(j, 1)
　　　　Exit For
　　　End If
　　Next j
　Next i
　.Cells(2, 24).Resize(n1).Value = s1
End With
End Sub

この回答へのお礼

ご返答頂きありがとうございます！
実際のデータで実行しましたが、特に問題もなく、転記のスピードも一瞬で、
ずっと悩んでいたので大変助かりました！
本当にありがとうございます！

お礼日時：2021/04/28 13:29