VBA: How can I limit a 'For Each' function - vba

Question

I am having a macro that checks the matching values from column A and row 2 in sheet2. Based on each value in the range B3 to C6 (dynamic field may get changed (there is maximum 7 location and below that 5 roles, may appears here ) in sheet1.
Problem with my code is that my loop "j" is not working as expected... It will result in executing the code 8 to 16 times in per below scenario (where I am expected it to run only 4 times)
Sub GetRowNum()
Dim rLoc
Dim rRol
Dim LocSrch1
Dim RolSrch1
Dim disRangeLoc As Range
Dim disRangeRol As Range
Dim i
Dim j
Dim shtA As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim lInter As Variant
Dim Table As Range
Set shtA = Sheets ("Sheet1") 'storing the sheets...
Set shtB = Sheets ("Sheet2")
shtA.Activate
rLoc = shtA.Range("B2").End(xlDown).Row
rRol = shtA.Range("C2").End(xlDown).Row 'the last row of the list
LocSrch1 = 2 'column A... changed if you need
Set disRangeLoc = Range(Cells(3, LocSrch1), Cells(rLoc, LocSrch1)) 'here need to change the 2 for
'1 if you do not want headers
RolSrch1 = 3 'column A... changed if you need
Set disRangeRol = Range(Cells(3, RolSrch1), Cells(rRol, RolSrch1))
For Each i In disRangeLoc 'for each item inside the list of prod going to discount
For Each j In disRangeRol
MsgBox i
MsgBox j
shtB.Activate
Set Table = shtB.Range("A1:H7")
On Error Resume Next
lRow = shtB.Application.WorksheetFunction.Match(j, Range("A:A"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lCol = shtB.Application.WorksheetFunction.Match(i, Range("2:2"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lInter = Application.WorksheetFunction(lCol, lRow).Value
On Error GoTo 0
If lRow > 0 Then
MsgBox Table.Cells(lRow, lCol).Value
End If
On Error GoTo 0
Next j
Next i
End Sub
My final target is to find the revenue under D7 as shown in image1 (sheet1) and this code is 1st step towards it... If someone had a better suggestion to calculate in such a simple way, kindly guide me.
Someone, please help me to correct my code... And I hope u understand my requirement... Else please ask, I will try to explain better
Thanks in advance

Answer 1

If you set For Each j In disRangeRol then it will take each value in the range you already defined. if you keep Set J = I.Offset(0, 1) then it will consider and check the value in 'i' if true it will take the value just right to it and won't go for Each values in disRangeRol, Try below code
Sub GetRowNum() 'find the value from Sheet2 if Location and Role matches
Dim rLoc
Dim rRol
Dim LocSrch1
Dim RolSrch1
Dim disRangeLoc As Range
Dim disRangeRol As Range
Dim I
Dim J
Dim shtA As Worksheet
Dim shtB As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim lInter As Variant
Dim Table As Range
Set shtA = Sheets("Sheet1")
Set shtB = Sheets("Sheet2")
shtA.Activate
rLoc = shtA.Range("B2").End(xlDown).row
rRol = shtA.Range("C2").End(xlDown).row 'the last row of the list
'with the discounted prods
'If you do not want headers,
'use A1 here
LocSrch1 = 2 'column B... changed if you need
Set disRangeLoc = Range(Cells(3, LocSrch1), Cells(rLoc, LocSrch1)) 'here need to change the 2 for
'1 if you do not want headers
RolSrch1 = 3 'column A... changed if you need
Set disRangeRol = Range(Cells(3, RolSrch1), Cells(rRol, RolSrch1))
For Each I In disRangeLoc 'for each item inside the list of prod going to discount
Set J = I.Offset(0, 1) 'it will check the value in i if yes it will take the value just right to it
shtB.Activate
Set Table = shtB.Range("A1:H7")
On Error Resume Next
lRow = shtB.Application.WorksheetFunction.Match(J, Range("A:A"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lCol = shtB.Application.WorksheetFunction.Match(I, Range("2:2"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lInter = Application.WorksheetFunction(lCol, lRow).Value
On Error GoTo 0
If lRow > 0 Then
'MsgBox I
'MsgBox J
MsgBox Table.Cells(lRow, lCol).Value
RevValue = Table.Cells(lRow, lCol).Value 'it will set the values each time the loop run
End If
On Error GoTo 0
shtA.Activate ' help to make sure you feed the date in right sheet, else data will get feed to Sheet2
ActiveCell.Value = RevValue & "," & ActiveCell.Value 'this will feed the date into the field using a comma separation
Next I
shtA.Activate
End Sub
Updated the code to feed the data into specific column as well