二つのリストを比べて部分一致する際に行ごと抽出するVBA

いつもお世話になっております。
前回質問した際（https://oshiete.goo.ne.jp/qa/10879923.html）
二つのリストを比べて同じもの（完全一致）するものを抽出する方法を伺ったのですが
今度は部分一致するものを行ごと抽出したいです。
連想配列の場合、LIKEで検索すべきまでは分かったのですが上手く動かず
どうにか助けていただけないでしょうか。

excel2007を使用しておりますので
どうぞよろしくお願いします。

SHEET1⇒大元のデータ
SHEET2⇒検索文字

SHEET2のA列には抽出したい項目があります。
そこでSHEET1のC列の中にとSHEET2のA列の文字が含まれているとき、
SHEET３の二行目以降に行ごとデータを抽出できないでしょうか。

SHEET1 (
（A列）　　　　 　　　（B列）　　　　（C列）
種類　　　　　 　　　産地　　　 　　　入荷予定
ミルクチョコレート 　フランス 　　　3月(品川)
ビターチョコレート 　イタリア　　　 1月(横浜)
ビターチョコレート　 フランス　　　 12月(立川)
ミルクチョコレート 　ベルギー 　　　1月(横浜)
ミルクチョコレート 　ベルギー 　　　3月(立川)

SHEET2
店舗（A列）
横浜 　
品川

SHEET３
（A列）　　　　　 （B列）　　　　　　　（C列）
入荷月　　　　　　　種類　　　　 　　　　産地
1月（横浜） 　　ビターチョコレート 　　イタリア
3月（横浜）　　 ミルクチョコレート 　　ベルギー
3月（品川) 　　　ミルクチョコレート 　　フランス

Option Explicit
Public Sub 入荷設定()
Dim row1 As Long
Dim row2 As Long
Dim row3 As Long
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim i As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim dicT As Object 'Dictionary
Dim Alrow As Object 'ArrayList
Dim key As Variant
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
maxrow1 = sh1.Cells(rows.Count, "A").End(xlUp).row 'A列最終行を求める
maxrow2 = sh2.Cells(rows.Count, "A").End(xlUp).row 'A列最終行を求める
sh3.Cells.ClearContents 'Sheet3クリア
sh3.Range("A1:C1").Value = sh2.Range("A1:C1").Value '見出しコピー
'C列を辞書登録（キー：C列の内容 値：行番号）
For row1 = 2 To maxrow1
key = sh1.Cells(row1, "C").Value
If dicT.exists(key) = False Then
Set Alrow = CreateObject("System.Collections.ArrayList") '.NET Frameworkへの参照
Alrow.Add row1
dicT.Add key, Alrow
Else
dicT(key).Add row1
End If
Next
row3 = 2
'Sheet2を参照
For row2 = 2 To maxrow2
key = sh2.Cells(row2, "A").Value
If dicT.Exists(key) Like sh2.Cells(row2, "B").Value Then '※true からLIKEに変更しています
For i = 0 To dicT(key).Count - 1
row1 = dicT(key)(i)
sh3.Cells(row3, "A").Value = key '入荷月
sh3.Cells(row3, "B").Value = sh1.Cells(row1, "A").Value '種類　'※できれば行ごとにしたいです
sh3.Cells(row3, "C").Value = sh1.Cells(row1, "B").Value '産地
row3 = row3 + 1
Next
Else
MsgBox ("Sheet2の" & row2 & "行:[" & key & "]はSheet1になし")
End If
Next
MsgBox ("完了")
End Sub

質問者からの補足コメント

• めぐみんさん
  前回はお世話になりました。
  いろいろ説明不足で申し訳ありません。
  この場合は（立川）とあるものは二つとも転記します。
  よろしくお願いします。

  No.2の回答に寄せられた補足コメントです。 補足日時：2018/12/23 19:21

• tom04さん
  アドバイスありがとうございます。
  試してみたのですが定義エラーと出てしまい。。。
  実際はもっとデータの量が多く、私が上手く扱えていないのかもしれません。。。

  No.1の回答に寄せられた補足コメントです。 補足日時：2018/12/23 19:22

• tom04さんありがとうございます。
  実際の元データはA列～AC列まであり
  一万行ぐらいあり、
  実際はK列に検索したい項目があります。
  対して検索項目は多くても200行ぐらいで
  A列にあります。
  
  なので単純に私の力量不足で応用できないのかもしれません。。。

  No.3の回答に寄せられた補足コメントです。 補足日時：2018/12/23 23:06

• ママチャリさんありがとうございます。
  こんな簡単なのがあるのですね。
  火曜日に早速試してみようと思います。

  No.4の回答に寄せられた補足コメントです。 補足日時：2018/12/23 23:08

• 風邪を引いてしまい検証が出来ず、
  返信が遅くなり大変申し訳ありません。
  ママチャリさんとめぐみんさんのアイディアで活用してみたのですが上手くいかず。。。
  よろしければ改造したものを提示していただけないでしょうか。
  
  ちなみに下の質問では入力者が"("が半角、全角だったり、その後に文字が続くこともあります(例　八王子急ぎ(3月)
  そのため抽出したいのはケース1、3の場合になります。
  
  お手数おかけして申し訳ありませんが
  よろしくお願いします。

  No.6の回答に寄せられた補足コメントです。 補足日時：2018/12/27 13:30

• 色々説明足らずにも関わらず丁寧な回答ありがとうございます。
  
  ①実際の列　：実際の列　：A列（種類）、B列（産地）、K列（入荷予定）で間違いありません。
  ②ケース2が含まれてても大丈夫です。
  
  基本的には3月(品川)(月/地名)で入力していますが、イレギュラーが起きた際に任意で入力しているため統一がないのが現状です。
  ただ、そういったイレギュラーなものについては省いても仕方ないと思っています。
  完全一致よりは部分一致の方が適しているかと思いましたので、よろしくお願い致します。

  No.8の回答に寄せられた補足コメントです。 補足日時：2018/12/28 00:35

No.4 回答者： ママチャリ 回答日時： 2018/12/23 20:27

多少の違いに目をつぶれるのであれば、「並べ替えとフィルタ-詳細設定」できるかもしれません。

VBEであれば、Range.AdvancedFilter メソッドを使います。こんな感じです。
目をつぶる点は、添付画像の赤文字の部分です。

Sub Macro1()
Sheets("Sheet1").Columns("A:C").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet2").Range("A1").CurrentRegion, _
CopyToRange:=Sheets("Sheet3").Range("A1:C1"), Unique:=False
End Sub

この回答へのお礼

アドバイスありがとうございました。
こういったやり方もあるんだと勉強になりました。
今後何かで活用できたらと思います。ありがとうございました！

お礼日時：2019/01/04 21:20

No.3 回答者： tom04 回答日時： 2018/12/23 19:32

No.1です。

＞実際はもっとデータの量が多く・・・

とはSheet2のデータ量も極端に多い！というコトでしょうか？
前回のコードはSheet1に数万行あっても数秒で終わるはずですが、
Sheet2のデータも数千、数万行ある場合はSheet2の方も配列にする必要があると思います。

Sheet2の実際のデータ数（行数）だけでも判れば、配列を使った方が速いかどうか判ります。

※　Sheet2も配列を使う場合は当然コードも変わってきます。m(_ _)m

No.2 回答者： めぐみん_ 回答日時： 2018/12/23 19:18

部分一致という場合、

ビターチョコレート　 フランス　　　 12月(立川)
ミルクチョコレート 　ベルギー 　　　3月(立川)

で、抽出したい単語が『立川』の時、どちらを転記するのでしょう。
または、

3月 (立川)　　ミルクチョコレート 　ベルギー
12月 (立川)　　ビターチョコレート　 フランス

と言う順番に入れ替えるのでしょうか？
これって前回も少し気になりましたが『月』の順番って重要なのでしょうか？

この回答へのお礼

すみません。言葉が足りてませんでHした。
月は関係なく、そのまま上から転記していくという感じです。
いろいろすみません。
よろしくお願いします。

お礼日時：2018/12/23 19:26