Блог

Сейчас я в отчаянии. 🙁

У меня есть список действий в колонке на листе. На другом листе у меня есть еще один список действий, некоторые из которых соответствуют записям в списке на первом листе. Код проходит через первый список и находит совпадение во втором списке. Затем он проверяет, сколько выходов имеет это совпадение, и если выходов больше одного, он добавляет еще одну строку в первый список данных, прямо под последней проверенной ячейкой этого списка. В этой новой строке должна быть записана запись, основанная на втором выводе. Если есть еще один вывод, добавляется еще одна новая строка и т. Д. до тех пор, пока не будет больше результатов той же деятельности. Затем он должен продолжить выполнение следующего действия из первого списка. Поэтому следующая ячейка активности должна быть перемещена с количеством строк, добавленных дополнительно во время проверки.

Проблема в том, что иногда кажется, что перемещения с количеством дополнительных строк недостаточно, поэтому бывает так, что следующая ячейка на самом деле является предыдущей из списка, т. Е. уже проверенной, а не новой. И таким образом возникает неопределенный цикл. Чтобы обойти это, я даже пытаюсь сохранить последнюю заполненную строку в значение, чтобы выполнить дополнительную проверку, если вычисляется более ранняя строка, но это, похоже, тоже не работает 🙁

То, что у меня есть, — это:

 …
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 = "? " amp; 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 и значением в качестве набора номеров строк для этого действия. Отсканируйте лист1 и используйте словарь для поиска совпадающих строк. Найдите в соответствующей строке ячейки с буквой «o» и скопируйте значения обратно в столбец Y листа 1 (вставляя строки по мере необходимости).

 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 amp; 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 amp; cell.Row).Value = "No Output"
            End If
        Else
            ws1.Range(COL_OUT amp; cell.Row).Value = "Nothing in Sheet1"
        End If
        Set cell = cell.Offset(1)
    Loop
    
    MsgBox "Done"
End Sub