Offset the x in a 'For each x' loop

Question

I am desperate now. :(

I have a list of activities in a column in a sheet. In another sheet I have another list of activities, some of which match entries in the list in the first sheet. The code goes through the first list and finds a match in the second list. Then it checks how many outputs this match has, and if there are more than one outputs, it adds another row in the first list of data, right below the last checked cell of that list. On that new row an entry based on the second output should get written. If there is a further output, another new row gets added etc. until there are no more outputs of the same activity. Then it shall continue with the next activity from the first list. That next activity cell shall be therefore moved with the number of rows added additionally during the check.

The problem is, sometimes that moving with the number of additional rows seems to not be enough, so it happens that the next cell is actually a previous one from the list, i.e. an already checked one, and not a new one. And thus an indefinite cycle occurs. To bypass this, I even try to save the last populated row to a value, so that an additional check gets performed if an earlier row gets calculated, but this does not seem to work either :(

What I have is:

…
For Each a In activity_list
    previousAddress = 0
    If flagOffset > 0 Then
        If rows_to_offset <> 0 Or flagsame > 0 Then
            Set canda = a.Offset(rows_to_offset, 0) 'check if the offset is enough
            If canda.Row <= lastR Then
                Set a = Sheets("Sheet1").Cells(lastR + 1, 3) 'if not enough, go to the last result populated row
            Else
             Set a = canda
             End If
        rows_to_offset = 0
        End If
    End If

    activityRow = a.Row
    activityValue = a.Value
    
   If activityValue <> 0 And Not activity_to_match_list.Find(activityValue, lookin:=xlValues) Is Nothing Then
        Set found_act_match = activity_to_match_list.Find(activityValue, lookin:=xlValues)
        Sheets("Sheet2").Activate
        Set range_to_search_for_outputs = Sheets("Sheet2").Range(Cells(found_act_match.Row, 2), Cells(found_act_match.Row, 500))
        If Not range_to_search_for_outputs.Find("o", lookat:=xlPart, lookin:=xlValues, SearchDirection:=xlNext) Is Nothing Then
            Set found_output = range_to_search_for_outputs.Find("o", lookin:=xlValues, SearchDirection:=xlNext)
            
            If found_output.Column <> 1
            firstAddress = found_output.Address
            
Do 
        … do something with the output value…
                ' Then take the found output from the match and take its status from the Sheet1:
                previousAddress = found_output.Address
                If op <> "" Then       
                    If Not op_list.Find(op, lookin:=xlValues) Is Nothing Then
                        Set found_output_match = op_list.Find(op, lookin:=xlValues)
                        Sheets("Sheet1").Activate
                        op_result = Cells(found_output_match.Row, "Y").Value
                            If Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "" Then
                                Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "? " & Format(op_result, "Percent")
                                lastR = Cells(activityRow + rows_to_offset, "Y").Row
                            End If
                    Else:
                            If Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "" Then
                                Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "Nothing in Sheet1"
                                lastR = Cells(activityRow + rows_to_offset, "Y").Row
                            End If
                    End If

                    Sheets("Sheet2").Activate
                    Set another = range_to_search_for_outputs.Find("o", after:=found_output, SearchDirection:=xlNext)
                    If Not another Is Nothing And another.Address <> found_output.Address Then 'if there is another output for the same activity, go to its output and continue as above
                            If another.Address <> firstAddress Then
                                Set found_output = another
                                Sheets("Sheet1").Activate
                                If Sheets("Sheet1").Cells(activityRow + rows_to_offset + 1, "C").Value <> activityValue Then 'if there isn't another row for the same activity yet
                                    Sheets("Sheet1").Rows(activityRow + 1).Insert
                                    Sheets("Sheet1").Cells(activityRow + 1, "C").Value = activityValue
                                    rows_to_offset = rows_to_offset + 1
                                    flagOffset = flagOffset + 1
                               Else:
                                flagsame = flagsame + 1 'if there is already another row for the same activity
                                rows_to_offset = rows_to_offset + 1
                               End If
                            End If
                    End If
                    
                Sheets("Sheet1").Activate
                End If
            Loop While (found_output.Address <> previousAddress) And (found_output.Address <> firstAddress)
            
            End If
          Else:
            Worksheets("Sheet1").Cells(activityRow, "Y").Value = "no Output"
            lastR = Cells(activityRow, "Y").Row
          End If
   ElseIf activity_to_match_list.Find(activityValue, lookin:=xlValues) Is Nothing Then
    Worksheets("Sheet1").Cells(activityRow, "Y").Value = "Nothing in Sheet1"
    lastR = Cells(activityRow, "Y").Row
    
   ElseIf a.Offset(1, 0).Value <> 0 Then
    Set a = a.Offset(1, 0)
   Else:
    Sheets("Sheet1").Activate
    …
   End If
   
   Set … to Nothing
  
   Next a

Answer 1

In principle use a dictionary with the key as the sheet2 activity and the value as a collection of row numbers for that activity. Scan down sheet1 and use the dictionary to find matching rows. Search along the matched row for cells with "o" and copy values back to sheet1 Column Y (inserting rows as required).

Sub FindOutputs()

    Const COL_OUT = "Y"

    Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
    Dim rng As Range, fnd As Range, sFirst As String
    Dim dict As Object, key, count As Integer
    Dim iLastRow As Long, i As Long, n As Long

    Set dict = CreateObject("Scripting.Dictionary")
    Set wb = ThisWorkbook

    ' sheet 2 - Activities to Search in Column A
    Set ws2 = wb.Sheets("Sheet2")
    iLastRow = ws2.Cells(Rows.count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        key = Trim(ws2.Cells(i, "A"))
        If Len(key) > 0 Then
            If Not dict.exists(key) Then
                ' collection holds row numbers for each activity
                dict.Add key, New Collection
            End If
            dict(key).Add CStr(i) ' add row
        End If
    Next
    
    ' sheet 1 - Activities in column A
    Set ws1 = wb.Sheets("Sheet1")
    Set cell = ws1.Range("A1")
    Do While Len(cell.value) > 0
        key = Trim(cell.Value)
        count = 0
        ' does activity exist on sheet2?
        If dict.exists(key) Then
            n = dict(key).count
            ' loop through matching rows
            For i = 1 To n
                r = dict(key).Item(i)
                ' search along the row for "o"
                Set rng = ws2.Cells(r, "B").Resize(1, 500)
                Set fnd = rng.Find("o", lookat:=xlPart, LookIn:=xlValues, SearchDirection:=xlNext)
                If Not fnd Is Nothing Then
                     sFirst = fnd.Address
                     ' do something with output value
                     Do
                         count = count + 1
                         If count > 1 Then
                            ' insert row
                            cell.Offset(1).EntireRow.Insert _
                                CopyOrigin:=xlFormatFromLeftOrAbove
                            Set cell = cell.Offset(1)
                            cell.Value = key
                         End If
                         ws1.Range(COL_OUT & cell.Row).Value = fnd.Value
                         Set fnd = rng.FindNext(fnd)
                     Loop While fnd.Address <> sFirst
                End If
            Next
            If count = 0 Then
                ws1.Range(COL_OUT & cell.Row).Value = "No Output"
            End If
        Else
            ws1.Range(COL_OUT & cell.Row).Value = "Nothing in Sheet1"
        End If
        Set cell = cell.Offset(1)
    Loop
    
    MsgBox "Done"
End Sub