Offset the x in a 'For each x' loop - excel

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