построение цикла на основе оператора if двух диапазонов в VBA

Question

Заранее благодарю за помощь.

Я пытаюсь создать макрос (который в конце концов станет частью большего макроса), который будет сравнивать два идентификатора и на основе результатов выполнит другую операцию. .

Код, который у меня есть на данный момент, копирует только значения для каждой строки без учета идентификатора в первом столбце. Вот код:

Sub movingValues()

    'declaring/setting variables

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim SheetOneRng As Range, SheetTwoRng As Range
    Dim cell As Range, i As Integer

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
    Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
    Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
    Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)

    SheetOneWs.Range("B2:D13").Value = ""

    For i = 2 To SheetTwoLastRow
        'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "No" Then
                SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "B").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Maybe" Then
                SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "C").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Yes" Then
                SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "D").Value = "No data"
        Next cell

    Next i


    Application.Calculation = xlCalculationManual
End Sub

Насколько я понимаю, мне нужно поместить это в другой цикл, чтобы соответствовать идентификаторам, пока я пытался:

For i = 2 To SheetOneLastRow


    For a = 2 To SheetTwoLastRow


    valTwo = Worksheets("SheetTwo").Range("A" & a).Value

    If Cells(i, 1) = valTwo Then

     'CODE FROM ABOVE'

    End if
  Next a
Next i

не делаетКажется, это работает так, как я намереваюсь, вся ваша помощь будет принята с благодарностью. Код изначально был взят из ответа здесь: Проблема с копированием значений на основе условия с одного листа на другой VBA

Еще раз спасибо за все ваши ответы.

С наилучшими пожеланиями, Сергей

Answer 1

Поскольку я не мог смотреть на ваш ужасно неэффективный код, я переработал его здесь, основываясь на данных, предоставленных в вашем предыдущем вопросе.

Что он делает, это зацикливается на столбце 2 листа 2Затем для каждой ячейки он находит соответствующий идентификатор и сохраняет строку в «Hit».

Затем он находит три значения в строке ячейки и добавляет месяц, связанный с каждым попаданием, в правильное место вмассив.

Затем он вставляет массив за один раз в правильный диапазон на листе 1.

Sub movingValues()

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim cel As Range, hit As Range
    Dim Foundrow As Integer
    Dim arr() As Variant

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("Sheet1")
    Set SheetTwoWs = ThisWorkbook.Worksheets("Sheet2")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row

    ReDim arr(1 To SheetOneLastRow - 1, 1 To 3)

    For Each cel In SheetTwoWs.Range("A2:A" & SheetTwoLastRow)
        Foundrow = SheetOneWs.Range("A1:A" & SheetOneLastRow).Find(cel.Value).Row - 1
            If Not Foundrow = 0 Then
                Set hit = SheetTwoWs.Rows(cel.Row).Find("No", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 1) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 1) = "No Data"
                End If
                Set hit = SheetTwoWs.Rows(cel.Row).Find("Maybe", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 2) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 2) = "No Data"
                End If
                Set hit = SheetTwoWs.Rows(cel.Row).Find("Yes", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 3) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 3) = "No Data"
                End If
            End If
    Next cel

    SheetOneWs.Range("B2:D" & SheetOneLastRow) = arr

End Sub

Как вы, вероятно, можете увидеть при попытке, сначала считывая значения в массивделает это в значительной степени мгновенным, так как это экономит на «дорогих» действиях записи. При наличии тестов и этой структуры она должна быть намного более простой и жесткой, чем ваш предыдущий код. Использование Find означает, что нужно только зацикливаться на каждой строке один раз, что еще больше повышает производительность.

Обратите внимание, лучше создать резервную копию ваших данных перед попыткой на случай непредвиденных результатов и / или ошибок.