VBA get values from 2 workbooks where value matches? - vba

Question

Scenario
I have three workbooks
Master
Planner
Phonebook
In my master workbook, i have a value in cell I8 on sheet 1.
Master (Sheet 1)
I8 = 2
On sheet 2 i have the following empty columns:
Master (Sheet 2)
Column A (number) Column B (Supplier) Column C (Contact)
I intend to populate these columns with data from both planner workbook and phonebook workbook.
In my planner, I have a list of numbers in column A and suppliers in Column N.
Numbers Supplier
2 A
2 B
2 C
3 D
4 E
2 F
I am trying to copy all the suppliers from my planner workbook that match the value in cell I8 (in this instance it is 2).
I am pasting the numbers (2) in column A and pasting the supplier names into column B in master workbook.
My code already copies and pastes these values fine.
(I am also copying other values from planner into other columns in master - but for this question, these are not relevant).
So this part of my code works fine.
The problem
Once the suppliers have been pasted into column B in master workbook - I also want to copy the contact name for each supplier from my workbook phonebook.
My phonebook workbook has sheets A-Z and suppliers are listed under these sheets alphabetically.
Phonebook:
Supplier (Column A) Contact Name (Column C)
A Linda
Aa Dave
Aa Terry
AB James
A | B | C | D etc... <----- Sheets
I need to look in each sheet in column A of the phonebook for a supplier name that matches the supplier name in column B (master).
If the supplier name matches then I want to copy the contact name in column C over to master workbook column C.
My result should look like this
Master (Sheet 2)
Column A (number) Column B (Supplier) Column C (Contact)
2 A Linda
2 A Linda
Here's my code:
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
For some reason, the code is Copying/pasting just 1 single contact name on the first row into master workbook.
I am also aware that at the moment I am only looking across one sheet.
With WB2.Worksheets(2)
I need this code to obviously look across all sheets for all supplier contact names.
Please can someone show me where I am going wrong and how to get this code to work? Thanks in advance.
EDIT:
I have composed the code suggested by user #BjornBogers
'Retrieve Contact Details for supplier
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
However, this does the same thing, only one contact name is being entered in the top row but nothing more.
EDIT 2:
With the code #R3uK provided, i seem to be getting the following issues:
Supplier names and other values are not copying across correctly.
The same value seems to repeat itself again and again in column I.
For some reason, this code creates another sheet? What is this sheet for?
The code is incredibly slow and i am having to wait 20 minutes or more.
Is there a way to speed this up?

Answer 1

I haven't tested this but you could try the following:
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