How to match two sets of cells on two sheets using vba - vba

Question

I am trying to match an ID cell from sheet 1 to and ID cell in sheet 2. If these match then I need to match a product cell from sheet 1 to a product cell in sheet two.
The ID cell in sheet 1 has multiples of the same ID in a column with different products in the next cell (column A = ID, column B = product).
In sheet 2 there is only one instance of each ID, however the product goes across the row. If the two criteria match, I need a 1 to be placed in the cell below the product.
This needs to be looped across the row and once the row finishes, move to the next ID in sheet 1. If the criteria do not match then the cell needs to be filled with a 0.
The trouble I am have is moving to the next ID. I have included the code and appreciate any help.
Public Sub test()
Dim ws As Worksheet, sh As Worksheet
Dim wsRws As Long, dataWsRws As Long, dataRng As Range, data_Rng As Range, data_cell As Range, datacell As Range
Dim shRws As Long, prodShRws As Long, resRng As Range, res_Rng As Range, results_cell As Range, product_cell As Range, shCols As Long
Set dataSht = Sheets("Device Import")
Set resSht = Sheets("Transform Pivot")
With dataSht
wsRws = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
dataWsRws = .Cells(.Rows.Count, "B").End(xlUp).Row
Set dataRng = .Range(.Cells(2, "A"), .Cells(wsRws, "A"))
Set data_Rng = .Range(.Cells(2, "B"), .Cells(wsRws, "B"))
End With
With resSht
shRws = .Cells(Rows.Count, "A").End(xlUp).Row
shCols = .Cells(1, Columns.Count).End(xlToLeft).Column
Set resRng = .Range(.Cells(2, "A"), .Cells(shRws, "A"))
Set res_Rng = .Range(.Cells(1, "B"), .Cells(1, shCols))
End With
i = 1
For Each data_cell In dataRng 'data sheet
For Each product_cell In res_Rng 'results sheet
For Each datacell In data_Rng 'data sheet
For Each results_cell In resRng 'results range
If data_cell = results_cell And datacell = product_cell Then
MsgBox data_cell.Value + " " + datacell.Value
results_cell.Offset(0, i) = 1 ' dcell = rcell so recell offset = 1
Else
MsgBox product_cell.Value + " " + results_cell.Value
results_cell.Offset(0, i) = 0 ' no match so rcell offset = 0
End If
If results_cell = "" Then
Exit For
End If
i = i + 1
Next results_cell ' Results ID column
i = 1
Exit For
Next datacell ' Data Product column cell
Next product_cell ' Results ID row
Next data_cell ' Data ID column cell
End Sub

Answer 1

An alternative approach would be
Initialize the resSht to 0's first
Loop only the dataSht looking at each ID Product pair
Use match to find the ID and product on resSht and fill in 1's as found
Public Sub Demo()
Dim dataSht As Worksheet, resSht As Worksheet
Dim rData As Range
Dim rwRes As Variant, clRes As Variant
Dim colResID As Long, rwResProd As Long
colResID = 1 '<-- Column in Result Sheet containing ID
rwResProd = 1 '<-- Row in Result Sheet containing Products
Set dataSht = Sheets("Device Import")
Set resSht = Sheets("Transform Pivot")
'Initialise to 0
With resSht
.Range(.Cells(rwResProd, .Columns.Count).End(xlToLeft).Offset(1, 0), _
.Cells(.Rows.Count, colResID).End(xlUp).Offset(0, 1)) = 0
End With
' Lookup each ID and Product pair from dataSht in resSht
With dataSht
For Each rData In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
rwRes = Application.Match(rData.Value2, resSht.Columns(colResID), 0)
If Not IsError(rwRes) Then
clRes = Application.Match(rData.Offset(0, 1).Value2, resSht.Rows(rwResProd), 0)
If Not IsError(clRes) Then
resSht.Cells(rwRes, clRes) = 1
Else
MsgBox "Product " & rData.Offset(0, 1).Value2 & " not found in Result Sheet", vbOKOnly + vbExclamation, "Missing Product"
End If
Else
MsgBox "ID " & rData.Value2 & " not found in Result Sheet", vbOKOnly + vbExclamation, "Missing ID"
End If
Next
End With
End Sub
Example Result