在 'For each x' 循环中偏移 x
Offset the x in a 'For each x' loop
我现在很绝望。 :(
我在 sheet 的专栏中有一个活动列表。在另一个 sheet 中，我有另一个活动列表，其中一些与第一个 sheet 中列表中的条目相匹配。该代码遍历第一个列表并在第二个列表中找到匹配项。然后它检查这个匹配项有多少个输出，如果有多个输出，它会在第一个数据列表中添加另一行，就在该列表最后一个检查的单元格的下方。在该新行上，应写入基于第二个输出的条目。如果有进一步的输出，则添加另一个新行等，直到不再有相同 activity 的输出。然后它将继续第一个列表中的下一个 activity。因此，下一个 activity 单元格应移动，并在检查期间额外添加行数。
问题是，有时移动额外的行数似乎还不够，所以碰巧下一个单元格实际上是列表中的前一个单元格，即已经检查过的单元格，而不是新的一。从而出现无限循环。为了绕过这个，我什至尝试将最后填充的行保存为一个值，以便在计算较早的行时执行额外的检查，但这似乎也不起作用:(
我有的是：
…
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
原则上使用字典，键为 sheet2 activity，值为 activity 的行号集合。向下扫描 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
我现在很绝望。 :(
我在 sheet 的专栏中有一个活动列表。在另一个 sheet 中，我有另一个活动列表，其中一些与第一个 sheet 中列表中的条目相匹配。该代码遍历第一个列表并在第二个列表中找到匹配项。然后它检查这个匹配项有多少个输出，如果有多个输出，它会在第一个数据列表中添加另一行，就在该列表最后一个检查的单元格的下方。在该新行上，应写入基于第二个输出的条目。如果有进一步的输出，则添加另一个新行等，直到不再有相同 activity 的输出。然后它将继续第一个列表中的下一个 activity。因此，下一个 activity 单元格应移动，并在检查期间额外添加行数。
问题是，有时移动额外的行数似乎还不够，所以碰巧下一个单元格实际上是列表中的前一个单元格，即已经检查过的单元格，而不是新的一。从而出现无限循环。为了绕过这个，我什至尝试将最后填充的行保存为一个值，以便在计算较早的行时执行额外的检查，但这似乎也不起作用:(
我有的是：
…
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
原则上使用字典，键为 sheet2 activity，值为 activity 的行号集合。向下扫描 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