VBA для копирования определенного значения в новую электронную таблицу, если удовлетворяет условию

Question

Я новичок в этом VBA для Excel. Я пытаюсь написать некоторый код, который будет проверять (для 2 конкретных столбцов: скажем, C и I) до тех пор, пока он не дойдет до определенного текста и не скопирует столбец рядом с этим значением (из предыдущего столбца) в другую электронную таблицу.

Например, проверьте, существует ли в столбце C и столбце I слово «Да»:

Если это так, вставьте значение (в соответствующем значении в столбце перед) в этом случае. ячейка: (1,2): 2000 и ячейка (2,9): 98 в новой электронной таблице.

До сих пор я построил этот код (он проверяет только столбец C)

1-я часть (только проверьте, существует ли искомое значение)

Sub Button1_Click()

    Dim i As Long
    With Worksheets("Sheet1") ' t
        On Error Resume Next
            i = Application.WorksheetFunction.Match("Yes", .Range("C:C"), 0)
        On Error GoTo 0

        If i <> 0 Then
            MsgBox "Yes found at " & .Cells(i, 3).Address(0, 0)
        Else
            MsgBox "Yes not found in Column"
        End If
    End With
    End Sub

Но я застрял, когда пытаюсь реализовать 2-ю часть (скопируйте значение из столбца рядом и вставьте его в другую электронную таблицу)

Answer 1

Вот мой ответ:

Sub Button1_Click()
    Dim i As Long: i = 1000000
    Dim j As Long
    Dim k As Range
    Dim resultC As Range
    Dim resultI As Range
    Dim Sht1 As Worksheet: Set Sht1 = Sheets("Sheets1")
    Dim Sht2 As Worksheet: Set Sht2 = Sheets("Sheets2")

    With Sht1
        For Each k In .Range(Cells(1, i), Cells(i, Range("C1").Column)) 'for each cells in the column C (Range("C1:C1000000")
            If k.Value = "YES" Then
                Set resultC = k 'store the findind into the var and
                Exit For 'exit the loop
            End If
        Next k

        For Each k In .Range(Cells(1, i), Cells(i, Range("I1").Column)) 'for each cells in the column I (Range("I1:I1000000")
            If k.Value = "YES" Then
                Set resultI = k
                Exit For
            End If
        Next k
    End With

    With Sht2
        j = .Range(Cells(1000000, 1), Cells(1000000, 1)).End.Row + 1 'find the last cell in the new list with the results
        .Range(Cells(j, 1), Cells(j, 1)).Value = resultC.Offset(0, -1).Value
        .Range(Cells(j, 2), Cells(j, 2)).Value = resultI.Offset(0, -1).Value
    End With
End Sub

Не знаю, что вы хотите сделать со значениями в столбцах A и G (на первом рисунке). Но, пожалуйста, дайте мне знать, если у вас есть какие-либо проблемы.