Using "For Each" to find results, nothing comes up

[PGNewbie]

I am matching two columns in a new workbook with two columns in Workbook 2, running the following code results in empty columns. I'm not sure if I am using the right approach to retrieve the information. Any suggestions how to achieve it?

Sub InsertDeviceName_NewBook()

Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet
      Dim wbnew As Workbook
      Dim c As Range, FR As Variant
      Dim d As Range
      Dim e As Range, rng1 As Range, rng2 As Range
      Dim lr1 As Long, lr2 As Long
      

      Application.ScreenUpdating = False
      
      
      Set w2 = Workbooks("Book2.xlsx").ActiveSheet
      Set w1 = Workbooks("Book1.xlsx").ActiveSheet
      
      
      
     w1.Range("B:D").Copy
     Set wbnew = Workbooks.Add 'creates new workbook
     Columns("A:A").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
     ActiveSheet.Name = w1.Name
     Set wsnew = wbnew.ActiveSheet 'sets the active sheet in the new workbook
     lr1 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
     lr2 = w2.Cells(Rows.count, 1).End(xlUp).Row
    
    
     wsnew.Sort.SortFields.Add2 Key:=Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With wsnew.Sort
        .SetRange Range("A1:C" & lr1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
 
 End With
    
Columns("B:B").Insert Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove
      
      Range("B1").Select
      ActiveCell.FormulaR1C1 = "Device Name"
      
      Dim lr3 As Long
      
      lr3 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
      
      Set rng1 = wsnew.Range("C2:D" & lr3)
      Set rng2 = w2.Range("C2:D" & lr2)
      
'create a loop to find matches between columns C and D in the new workbook
'and match with columns C and D in workbook 2, upon a match retrieve the information
'in column B in workbook2 and add it to Columns B in the new workbook
For Each d In rng1
    FR = Application.Match(d, rng2)
    If IsNumeric(FR) Then
    d.Offset(, -1).Value = w2.Range("B" & FR).Value
    End If
    
Next d

Application.ScreenUpdating = True

End Sub

 

[StephenCrump]

Your problem is with this line, because rng2 has two columns

FR = Application.Match(d, rng2)

There are different ways you can construct a two-column Match(). Here's one based on a formula like: =MATCH(1,(A1=C$1:C$10)*(B1=D$1:D$10),)

Dim i As Long
'...
For i = 2 to lr3
    FR = Evaluate("MATCH(1,(C" & i & "=" & rng2.Columns(1).Address(, , , True) & ")*(D" & i & "=" & rng2.Columns(2).Address(, , , True) & "),0)")
    '...
Next i

Or you could use VBA in a nested loop. For each row in rng1, loop through all rows of rng2 looking for a two-column match.

 

[DanteAmor]

Here a macro with another approach for you to consider.

Sub matching_two_columns()
  Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet, wbnew As Workbook
  Dim a As Variant, b As Variant, c As Variant, dic As Object, i As Long
  Application.ScreenUpdating = False
 
  Set w1 = Workbooks("Book1.xlsx").ActiveSheet
  Set w2 = Workbooks("Book2.xlsx").ActiveSheet
 
  'creates new workbook
  w1.Range("B:D").Copy
  Set wbnew = Workbooks.Add
  Set wsnew = wbnew.Sheets(1)
  wsnew.Range("A1").PasteSpecial xlPasteValues
  wsnew.Columns("B:B").Insert Shift:=xlToRight
  wsnew.Range("B1").Value = "Device Name"
  a = wsnew.Range("C2:D" & wsnew.Range("C" & Rows.Count).End(3).Row).Value2
 
  'stores columns C and D(as key) an column B (as item) from w2 in object Dic
  Set dic = CreateObject("Scripting.Dictionary")
  b = w2.Range("B2:D" & w2.Range("B" & Rows.Count).End(3).Row).Value2
  For i = 1 To UBound(b)
    dic(b(i, 2) & b(i, 3)) = b(i, 1)
  Next
 
  'Loop column C and D from newsheet and look in the Dic key. If it exists, take the Dic data
  ReDim c(1 To UBound(a, 1), 1 To 1)
  For i = 1 To UBound(a)
    If dic.exists(a(i, 1) & a(i, 2)) Then c(i, 1) = dic(a(i, 1) & a(i, 2))
  Next
 
  'Put the results
  wsnew.Range("B2").Resize(UBound(c)).Value = c
End Sub