VLOOKUP関数のようなもので部分一致する行を複数、抽出したい

Public Sub copyFilteredDatas()

    Dim rDatasHD    As Range
    Dim rDatasD     As Range
    Dim rResult     As Range
    Dim lDataCount  As Long
    Dim lRow    As Long
    Dim sKey    As String

    Application.ScreenUpdating = False

    With Sheet2
        'オートフィルター用ダミーヘッダ追加
        .Rows(1).Insert
        .Range("A1").Value = "DummyHead"

        'データ取得元（ヘッダー含む）
        Set rDatasHD = Sheet2.Range("A1").CurrentRegion

        'データ取得元（ヘッダー含まず）
        Set rDatasD = rDatasHD.Resize(rDatasHD.Rows.Count - 1).Offset(1)

        'データ件数
        lDataCount = rDatasD.Rows.Count
    End With

    lRow = 1

    If rDatasHD.Parent.AutoFilterMode Then
        'オートフィルター解除
        rDatasHD.AutoFilter
    End If

    Do Until lRow = Sheet1.Rows.Count
        'フィルターキー
        sKey = Sheet1.Range("A" & CStr(lRow)).Value
        sKey = "*" & sKey & "*"

        If rDatasHD.Parent.FilterMode Then
            'オートフィルタークリア
            rDatasHD.Parent.ShowAllData
        End If

        'オートフィルター
        rDatasHD.AutoFilter Field:=1, Criteria1:=sKey

        If rDatasHD.SpecialCells(xlCellTypeVisible).Count > 1 Then
            '可視セルのみ
            Set rResult = rDatasD.SpecialCells(xlCellTypeVisible)

            'コピー
            rResult.Copy Sheet1.Range("F" & CStr(lRow))
        End If

        '次のキー行（連続した行入力には非対応）
        lRow = Sheet1.Range("A" & CStr(lRow)).End(xlDown).Row
    Loop

    If rDatasHD.Parent.AutoFilterMode Then
        'オートフィルター解除
        rDatasHD.AutoFilter
    End If

    'ダミーヘッダー削除
    Sheet2.Rows(1).Delete

    Application.ScreenUpdating = True

End Sub