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

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