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

出于某种原因，代码是将第一行中的1个单一联系人名称复制/粘贴到主工作簿中。

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

With WB2.Worksheets(2)

我需要使用此代码来查看所有供应商联系人姓名的所有表格。

有人可以告诉我我哪里出错了以及如何使这段代码生效？提前谢谢。

编辑：

我编写了用户@BjornBogers

建议的代码

＆＃39;检索供应商的联系方式

            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

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

2 个答案: