VBA从值匹配的2个工作簿中获取值？

Question

场景

我有三本工作簿

Master
Planner
Phonebook

在我的主工作簿中，我在工作表 1 的单元格 I8 中有一个值。

主（表 1）

I8 = 2

在第 2 页上，我有以下空列：

主（表 2）

Column A (number)      Column B (Supplier)     Column C (Contact)

我打算用计划员工作簿和电话簿工作簿中的数据填充这些列。

在我的规划器中，我在 A 列中有一个数字列表，在 N 列中有供应商列表。

Numbers     Supplier    
2           A
2           B
2           C
3           D
4           E
2           F

我正在尝试从计划员工作簿中复制与单元格 I8 中的值匹配的所有供应商（在本例中为 2）。

我将 A 列中的数字 (2) 粘贴到主工作簿的 B 列中。

我的代码已经很好地复制和粘贴了这些值。 （我还将其他值从 planner 复制到 master 的其他列中 - 但对于这个问题，这些不相关）。

所以我的这部分代码工作正常。

问题

将供应商粘贴到主工作簿的 B 列后 - 我还想从我的工作簿电话簿中复制每个供应商的联系人姓名。

我的电话簿工作簿有表格 A-Z，供应商按字母顺序列在这些表格下。

电话簿：

    Supplier (Column A)       Contact Name (Column C)

    A                            Linda
    Aa                           Dave
    Aa                           Terry
    AB                           James

A | B | C | D etc...    <----- Sheets

我需要在电话簿 A 列中的每张表中查找与 B 列（主）中的供应商名称相匹配的供应商名称。

如果供应商名称匹配，那么我想将 C 列中的联系人姓名复制到主工作簿 C 列。

我的结果应该是这样的

主（表 2）

Column A (number)      Column B (Supplier)     Column C (Contact)
2                      A                       Linda
2                      A                       Linda

这是我的代码：

Option Explicit

Sub CreateAnnounce()

Dim WB As Workbook
Dim WB2 As Workbook
Dim i As Long
Dim i2 As Long
Dim j As Long
Dim LastRow As Long
Dim j2 As Long
Dim LastRow2 As Long
Dim ws As Worksheet

'Open Planner
On Error Resume Next
Set WB = Workbooks("2017 Planner.xlsx")
On Error GoTo 0
If WB Is Nothing Then 'open workbook if not open
    Set WB = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx")
End If

'Open PhoneBook
On Error Resume Next
Set WB2 = Workbooks("Phone Book for Food Specials.xls")
On Error GoTo 0
If WB2 Is Nothing Then 'open workbook if not open
    Set WB2 = Workbooks.Open("G:\BUYING\Food Specials\1. General\Phone Book\Phone Book for Food Specials.xls")
End If

' ======= Edit #2 , also for DEBUG ======
With WB.Worksheets(1)
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    j = 2

    For i = 1 To LastRow


        ' === For DEBUG ONLY ===
        Debug.Print CInt(ThisWorkbook.Worksheets(1).Range("I8").Value)


        If CInt(ThisWorkbook.Worksheets(1).Range("I8").Value) = .Range("A" & i).Value Then ' check if Week No equals the value in "A1"

                ThisWorkbook.Worksheets(2).Range("A" & j).Value = .Range("A" & i).Value
                ThisWorkbook.Worksheets(2).Range("B" & j).Value = .Range("N" & i).Value
                ThisWorkbook.Worksheets(2).Range("H" & j).Value = .Range("K" & i).Value
                ThisWorkbook.Worksheets(2).Range("I" & j).Value = .Range("L" & i).Value

                ThisWorkbook.Worksheets(2).Range("J" & j).Value = .Range("M" & i).Value
                ThisWorkbook.Worksheets(2).Range("K" & j).Value = .Range("G" & i).Value

                ThisWorkbook.Worksheets(2).Range("L" & j).Value = .Range("O" & i).Value
                ThisWorkbook.Worksheets(2).Range("M" & j).Value = .Range("P" & i).Value

                ThisWorkbook.Worksheets(2).Range("N" & j).Value = .Range("W" & i).Value
                ThisWorkbook.Worksheets(2).Range("O" & j).Value = .Range("Z" & i).Value



                'Retrieve Contact Details for supplier

                'Worksheet 1



              'Retrieve Contact Details for supplier
             With WB2.Worksheets(2)
            LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
            j2 = 2

            For i2 = 1 To LastRow2
            Dim rngToFill As Range
            Set rngToFill = .Range("C2")

            Do

            Debug.Print ThisWorkbook.Worksheets(2).Range("B" & j2).Value

            If ThisWorkbook.Worksheets(2).Range("B" & j2).Value Like .Range("A" & i2).Value Then ' check if Company equals the value in "B1 Phonebook"

            ThisWorkbook.Worksheets(2).Range("C2").Value = .Range("C" & i2).Value

            Set rngToFill = rngToFill.Offset(1, 0)


            End If

            Loop

            Next i2
            End With










           'Retrieve Contact Details for supplier - END




            End If

    Next i
End With


End Sub

由于某种原因，代码将第一行上的一个联系人姓名复制/粘贴到主工作簿中。

我也知道目前我只看一张纸。

With WB2.Worksheets(2) 

我需要此代码来明显地查看所有工作表中的所有供应商联系人姓名。

请有人告诉我哪里出了问题以及如何让这段代码工作？提前致谢。

编辑：

我已经编写了用户@BjornBogers 建议的代码

'检索供应商的联系方式

            Dim FoundCellRng As Range
            Dim ContactValue As String
            Dim SearchStr As String

            For i2 = 1 To 26
                'Assuming --> ThisWorkbook.Worksheets(2).Range("B1").Value is what you are looking for?
                SearchStr = ThisWorkbook.Worksheets(2).Range("B2").Value
                Set FoundCellRng = WB2.Worksheets(i2).Range("A2:A200").Find(SearchStr)
                If (FoundCellRng Is Nothing) Then
                    'Didn't find anything
                Else
                    'We found it
                    ContactValue = WB2.Worksheets(i2).Cells(FoundCellRng.Row, FoundCellRng.Column + 2).Value
                    ThisWorkbook.Worksheets(2).Range("C" & j).Value = ContactValue
                    Exit For
                End If
            Next i2


           'Retrieve Contact Details for supplier - END

但是，这也是同样的事情，在第一行只输入了一个联系人姓名，仅此而已。

编辑 2：

使用提供的代码@R3uK，我似乎遇到了以下问题：

供应商名称和其他值未正确复制。 相同的值似乎在第一列中一次又一次地重复。

由于某种原因，这段代码创建了另一个工作表？这张表是干什么用的？

代码非常慢，我不得不等待 20 分钟或更长时间。 有没有办法加快速度？

Answer 1

我没有对此进行测试，但您可以尝试以下方法：

                Dim FoundCellRng As Range
                Dim ContactValue As String
                Dim SearchStr As String

                For i = 1 To 26
                    'Assuming --> ThisWorkbook.Worksheets(2).Range("B1").Value is what you are looking for?
                    SearchStr = ThisWorkbook.Worksheets(2).Range("B1").Value
                    Set FoundCellRng = WB2.Worksheets(i).Range("A1:A100").Find(SearchStr)
                    If (FoundCellRng Is Nothing) Then
                        'Didn't find anything
                    Else
                        'We found it
                        ContactValue = WB.Worksheets(i).Cells(FoundCellRng.Row, FoundCellRng.Column + 2).Value
                        Exit For
                    End If
                Next i

Answer 2

Sub CreateAnnounce()
Dim WbMaster As Workbook
Dim wSMaster1 As Worksheet
Dim wSMaster2 As Worksheet
Dim wSMastTemp As Worksheet
Dim WbPlan As Workbook
Dim wSPlan1 As Worksheet
Dim WbPhone As Workbook
Dim wSPhone As Worksheet
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim rngToFill As Range
Dim rngToChk As Range


Set WbMaster = ThisWorkbook
Set wSMaster1 = WbMaster.Sheets(1)
Set wSMaster2 = WbMaster.Sheets(2)
Set wSMastTemp = WbMaster.Sheets.Add
'''Open Planner
Set WbPlan = GetWB("2017 Planner.xlsx", "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx")
Set wSPlan1 = WbPlan.Sheets(1)
'''Open PhoneBook
Set WbPhone = GetWB("Phone Book for Food Specials.xls", "G:\BUYING\Food Specials\1. General\Phone Book\Phone Book for Food Specials.xls")

With wSPlan1
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    j = 2
    For i = 1 To LastRow
        '''Check if Week No equals the value in "A1"
        If CInt(wSMaster1.Range("I8").Value) = .Range("A" & i).Value Then
            wSMaster2.Range("A" & j).Value = .Range("A" & i).Value
            wSMaster2.Range("B" & j).Value = .Range("N" & i).Value
            wSMaster2.Range("H" & j & ":J" & j).Value = .Range("K" & i & ":M" & i).Value
            wSMaster2.Range("K" & j).Value = .Range("G" & i).Value
            wSMaster2.Range("L" & j & ":M" & j).Value = .Range("O" & i & ":P" & i).Value
            wSMaster2.Range("N" & j).Value = .Range("W" & i).Value
            wSMaster2.Range("O" & j).Value = .Range("Z" & i).Value
            '''Store those infos for next results
            wSMastTemp.Cells.Clear
            wSMastTemp.Range("A1:O1").Value = wSMaster2.Range("A" & j & ":O" & j).Value

            '''Retrieve Contact Details for supplier
            Set rngToFill = wSMaster2.Range("C" & j)
            For Each wSPhone In WbPhone.Sheets
                With wSPhone
                    '''Define properly the Find method to find all
                    Set rngToChk = .Columns(1).Find(What:=wSMaster2.Range("B" & j).Value, _
                                After:=.Cells(1, 1), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False, _
                                SearchFormat:=False)

                    '''If there is a result, keep looking with FindNext method
                    If Not rngToChk Is Nothing Then
                        FirstAddress = rngToChk.Address
                        Do
                            '''Transfer the cell value to the master
                            rngToFill.Value = rngToChk.Offset(, 2).Value

                            '''Go to next row on the template for next Transfer
                            Set rngToFill = rngToFill.Offset(1, 0)
                            '''Copy the Info from 1st row for the next result
                            wSMaster2.Range("A" & rngToFill.Row & ":O" & rngToFill.Row).Value = wSMastTemp.Range("A1:O1").Value

                            '''Look until you find again the first result in that sheet
                            Set rngToChk = .Columns(1).FindNext(rngToChk)
                        Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress
                    Else
                    End If
                End With 'wSPhone
          Next wSPhone
          '''Restart to fill from the next available row
          j = rngToFill.Row
          '''Clean Data that was there for the next result of this test
          wSMaster2.Range("A" & j & ":O" & j).ClearContents
        End If
    Next i
End With

Application.DisplayAlerts = False
wSMastTemp.Delete
Application.DisplayAlerts = True
End Sub


Public Function GetWB(FileName As String, FileFullPath As String) As Workbook
    On Error Resume Next
    Set GetWB = Workbooks(FileName)
    On Error GoTo 0
    If GetWB Is Nothing Then 'open workbook if not open
        Set GetWB = Workbooks.Open(FilePath)
        DoEvents
    End If
End Function