部分一致したら、一致したデータと隣のセルの2つのデータを、一致したセルの隣の2列にまたがる空白セルに貼り付けていきたい

標準モジュールに以下のコードを貼り付けて、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）。値だけを複写の対象として、セルの書式などは複写していません（やろうと思えばできます）。