部分一致したら､一致したﾃﾞｰﾀと隣のｾﾙの2つのﾃﾞｰﾀを､一致したｾﾙの隣の2列にまたがる空白ｾﾙに貼り付けていきたい今､ExcelﾌｧｲﾙにSheet1､Sheet2があり｡ S…

部分一致したら､一致したﾃﾞｰﾀと隣のｾﾙの2つのﾃﾞｰﾀを､一致したｾﾙの隣の2列にまたがる空白ｾﾙに貼り付けていきたい

今､ExcelﾌｧｲﾙにSheet1､Sheet2があり｡
Sheet1のA列には､以下のようなﾃﾞｰﾀが5万行ぐらいあります｡

※(行目)｜文字列

1｜ddcccりんごaaab
2｜ddeりんごaaa
3｜aaaaごりらあdee
4｜aaaらっこsbes
･
･
そしてSheet2のC列にも5万行ぐらい､以下のようなﾃﾞｰﾀが入っています｡

1｜りんご
2｜らくだ
3｜ごりら
4｜らっこ
5｜ﾗｲｵﾝ
･
･

こういった状況におきまして｡
もしSheet2のC列のｷｰﾜｰﾄﾞが､Sheet1のA列のｾﾙに含まれていた場合｡
その隣の空白にしておいたSheet1のB列とC列のｾﾙへ｡
一致したSheet2のC列のｷｰﾜｰﾄﾞのｾﾙと､その隣にあるD列のｾﾙをｺﾋﾟｰして｡
Sheet1の一致したA列のｾﾙの隣のB列とC列に､貼り付けていきたいのです｡

そのような処理がﾏｸﾛで可能でしたらお教えいただけないでしょうか｡
よろしくお願い致します｡

標準ﾓｼﾞｭｰﾙに以下のｺｰﾄﾞを貼り付けて､Sheet1 を表示している状態で put_by_keyword_list ｻﾌﾞﾙｰﾁﾝを実行してください｡

Sub put_by_keyword_list()
 On Error GoTo ErrorHandler

 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual

 Dim keyword()

 Set ref_s = Sheets("Sheet2")

  ' C列の最終行を調べる
 max_kwd = ref_s.Cells(Rows.Count, 3).End(xlUp).Row

 ReDim keyword(max_kwd)
 For r = 1 To max_kwd
 keyword(r) = ref_s.Cells(r, 3).Value
 Next

  ' A列の最終行を調べる
 last_row = Cells(Rows.Count, 1).End(xlUp).Row

 r = 2
 Do While r <= last_row
 txt = Cells(r, 1).Value
 For i = 1 To max_kwd
 If InStr(txt, keyword(i)) > 0 Then
 Cells(r, 2).Value = ref_s.Cells(i, 3).Value
 Cells(r, 3).Value = ref_s.Cells(i, 4).Value
 Exit For
 End If
 DoEvents
 Next
 r = r + 1
 Loop

FINAL:
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic

 Exit Sub

ErrorHandler:
 GoTo FINAL

End Sub

Sheet2 のｷｰﾜｰﾄﾞが入っている C 列には空白のｾﾙがないことを前提にしています｡
また､複数のｷｰﾜｰﾄﾞがﾋｯﾄするﾃﾞｰﾀの場合には､先に見つかった(Sheet2 で行番号が若い)ｷｰﾜｰﾄﾞの行の C列と D列を複写します｡

特別に速くはない数年前のﾉｰﾄPC で､ｷｰﾜｰﾄﾞが 50000件､対象のﾃﾞｰﾀが 55000件､Sheet2 のｷｰﾜｰﾄﾞがひとつもﾋｯﾄしないﾃﾞｰﾀが 170件ほどあるﾃｽﾄﾃﾞｰﾀで試したところ､17分20秒ほどかかりました (´･ω･｀)

激しく時間がかかるため､値のｺﾋﾟｰにはｸﾘｯﾌﾟﾎﾞｰﾄﾞを使う Copy ﾒｿｯﾄﾞを使いませんでした(*1)｡値だけを複写の対象として､ｾﾙの書式などは複写していません(やろうと思えばできます)｡

*1：このﾏｸﾛを動かしている間､ｸﾘｯﾌﾟﾎﾞｰﾄﾞが空にされるため､他の作業をやりながら､というわけにいかなくなってしまいます