偏移'For each x'循环中的 x

Question

我现在很绝望。(

我在工作表的一栏中有一个活动列表。在另一张表中，我有另一个活动列表，其中一些与第一张表中的列表条目相匹配。代码遍历第一个列表并在第二个列表中找到匹配项。然后它检查这个匹配有多少输出，如果有多个输出，它就在第一个数据列表中添加另一行，就在该列表中最后一个被检查的单元格的正下方。应该在新行中写入基于第二个输出的条目。如果有进一步的输出，则添加另一个新行，直到没有相同活动的更多输出。然后继续执行第一个列表中的下一个活动。因此，下一个活动单元格将随着在检查期间额外添加的行数而移动。

问题是，有时随着额外行数的移动似乎还不够，所以下一个单元格实际上是列表中的前一个，即已经检查过的一个，而不是一个新的。这样一个无限循环就发生了。为了绕过这个问题，我甚至尝试将最后填充的行保存为一个值，以便在计算较早的行时执行额外的检查，但这似乎也不起作用:(

我有的是:

…
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

原则上使用字典，其中键作为sheet2活动，值作为该活动的行号集合。扫描sheet1并使用字典查找匹配的行。沿着匹配行搜索带有"o"的单元格。并将值复制回sheet1 Y列(根据需要插入行)。

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