複数列、複数行にわたって合致する名前に対応する値を別ファイルから取得する

Question

VBA初心者です。
何卒ご教示をいただきたく、宜しくお願い申し上げます。

B2セルの名前について、別ファイルを参照し、
その別ファイルのB列から合致した名前を検索、
その別ファイルの対応するY列とZ列の値を
C列およびD列に記入するマクロを組みたいと考えています。
なお、別ファイルの対応するY列とZ列の値は複数ありますので、
C列およびD列は複数行記入されることを想定しています。
コードをインターネットで見よう見まねで書いてみたのですが、
対応する値がそもそも記入されないという状況です。
さらに複数列、複数行となると、どこをどう記載してよいものか、手が付けられていません。

※下記ご参考までに現在書いてみたコードを記載いたします。

Option Explicit

Sub 検索()

    Dim res As Worksheet
    Dim z As Long
    Set res = Worksheets("検索")
    z = res.Cells(res.Rows.Count, "A").End(xlUp).Row

Debug.Print res.Name, z

    Dim sPath As String, fn As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng1 As Range, rng2 As Range
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    For Each wb In Workbooks
       If wb.Name = fn Then Exit For
    Next wb
    If wb Is Nothing Then
      Set wb = Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    End If
    Set ws = wb.Worksheets("p_data")
    Set rng1 = ws.Range("B1:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    Set rng2 = ws.Range("Y1:Z" & ws.Cells(ws.Rows.Count, "Z").End(xlUp).Row)

Debug.Print wb.Name, ws.Name, rng1.Address, rng2.Address

    Dim i As Long
    Dim x As String
    For i = 2 To z
        '氏名の値を取得
        x = res.Cells(i, 2).Value
            '送付先分類の値を表示
        With Application.WorksheetFunction
On Error Resume Next
            res.Cells(i, 3).Value = .Index(rng1, .Match(x, rng2.Value, 0), 1)
On Error GoTo 0
        End With

Debug.Print i, x, ws.Name, res.Cells(i, 2).Value

Next

End Sub

分からないことばかりでお恥ずかしい限りですが、
何卒お力添えいただければ幸いです。
宜しくお願い申し上げます。

※追記
質問に目を通していただきまして、誠にありがとうございます。

検索シート、別ファイルのシート、のデータ例
処理後の検索シートの結果、

上記につきまして、画像を添付いたします。
イメージが湧きますでしょうか。
恐れ入りますが、宜しくお願い申し上げます。

●検索シート

●別ファイルのシート（氏名・会社名等は白で塗りつぶしています）

●処理後の検索シート

お手数お掛けいたしますが、何卒ご教示の程、宜しくお願い申し上げます。

Comments

[hatena19]

検索シート、別ファイルのシート、のデータ例
処理後の検索シートの結果、
が分かるような画像を貼り付けもらうと回答が付きやすいかと。

[opsy]

コメントありがとうございます。
イメージ画像を追記させていただきました。

[hatena19]

提示の画像だと、検索シートの名前は1件だけですが、実際は複数ありますよね。
検索結果が複数の場合は、空行を挿入して、そこに結果を表示させるということですか。

名前　検索　太郎
　　　検索　次郎

となっているとして、結果は、

名前　検索　太郎　CO　　2004/3/24
　　　　　　　　　SiSC　2004/5/7
　　　検索　次郎　CO　　2004/6/20

ということでしょうか。

[opsy]

すみません、言葉足らずでした。
実際に検索を行う名前は1件ずつで、例えば「検索太郎」ですので、
「検索太郎」のマッチしたデータが２行、３行にきてしまって問題ありません。
（「検索次郎」を同時に検索することはないということです）

Answer 1

Sub 検索()

    Dim res As Worksheet, wFind As Range
    Set res = ThisWorkbook.Worksheets("検索")
    Set wFind = res.Range("B2")

    Dim sPath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    
    Dim wb As Workbook
    For Each wb In Workbooks
       If wb.FullName = sPath Then Exit For
    Next wb
    If wb Is Nothing Then
      Set wb = Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    End If
    
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        If ws.name = "p_data" Then Exit For
    Next ws
    If ws Is Nothing Then Exit Sub
    
    Dim c As Range, r As Long
    For Each c In ws.UsedRange.Columns("B").Cells
        If c.Value = wFind.Value Then
            wFind.Offset(r, 1).Resize(, 2).Value = c.Offset(, 24).Resize(, 2).Value
            r = r + 1
        End If
    Next

End Sub

Comments

[opsy]

ご回答、誠にありがとうございます。
コードのご提示、重ねて感謝申し上げます。
色々なアプローチ方法があるんですね。
大変勉強になりました。
また何かありました際には、恐れ入りますが、宜しくお願い申し上げます。

Answer 2

あなたのソースを修正してみました。

Sub 検索()

    Dim res As Worksheet
    Dim z As Long
    Set res = Worksheets("検索")
    Dim name As String
    '検索　名前取得
    name = res.Cells(2, "B").Value
    z = res.Cells(res.Rows.Count, "A").End(xlUp).Row

    Debug.Print res.name, z

    Dim sPath As String, fn As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng1 As Range, rng2 As Range
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    For Each wb In Workbooks
        If wb.name = fn Then Exit For
    Next wb
    If wb Is Nothing Then
        Set wb = Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    End If
    Set ws = wb.Worksheets("p_data")
    Dim maxrow As Long
    Dim wrow As Long
    Dim res_row As Long
    'B列　最終行取得
    maxrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
    res_row = 2
    '２～最終行まで繰り返す
    For wrow = 2 To maxrow
        '検索対象名前と一致していれば
        If ws.Cells(wrow, "B").Value = name Then
            '送付分類と発送日を設定
            res.Cells(res_row, "C").Value = ws.Cells(wrow, "Y").Value
            res.Cells(res_row, "D").Value = ws.Cells(wrow, "Z").Value
            res_row = res_row + 1
        End If
    Next
    If res_row = 2 Then
        MsgBox ("該当なし")
    Else
        MsgBox ("完了")
    End If


End Sub

Comments

[opsy]

迅速なご回答、誠にありがとうございます。
また、コードのご提示、重ねて感謝申し上げます。
このような解決法があったとは、目からウロコです。
そして、動作が正常に行われることを確認いたしました。
僭越ながらベストアンサーとさせていただきます。
また何かありました際には、恐れ入りますが、宜しくお願い申し上げます。

Answer 3

回答ではありません。補足要求です。

添付図のようにB列に検索対象の名前が並んでいると、
検索太郎のマッチしたデータが２行、３行に（送付先分類＝CO,SiSC）あります。
次に徳川家康で、もしマッチしたデータが２件あれば、４行（C4,D4）、５行（C5,D5）に書き込めば良いのでしょうか。そうだとすると、名前と送付先分類の対応が判らなくなりますが、それでよいのでしょうか。

Comments

[opsy]

すみません、言葉足らずでした。
実際に検索を行う名前は1件ずつで、例えば「検索太郎」ですので、
「検索太郎」のマッチしたデータが２行、３行にきてしまって問題ありません。
（「徳川家康」「織田信長」を同時に検索することはないということです）