Скопировать строку данных на основе критериев И «метки», скопировавшей данные в последнем столбце.

Question

У меня есть рабочий код, который проверяет критерии в каждой строке и, если встречается, копирует всю эту строку данных в другую рабочую книгу. Но! Мне нужно иметь возможность добавлять текст в последний столбец скопированных данных (столбец S), который по существу обозначает, какие критерии были выполнены, что заставило код скопировать его, потому что скоро я буду расширяться для проверки нескольких различных критериев.

Таким образом, для каждой строки, которая соответствует критериям и копируется, я хочу добавить «Criteria1» рядом с ним в столбце S новой рабочей книги (это всегда будет столбец S, который будет первым доступным столбцом).

Я исказил этот код вместе с помощью наследования и всей вашей помощи, поэтому я даже не знаю, с чего начать.

Private Sub Workbook_AfterSave(ByVal Success As Boolean)

Dim CoderBook As Workbook
Dim Referrals As Worksheet
Dim Review As Workbook
Dim Crit As Worksheet
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long

Set CoderBook = Workbooks.Open("Coder Referrals.xlsx")
Set Referrals = CoderBook.Sheets("Sheet1")

Set Review = ThisWorkbook
Set Crit = Review.Sheets("Criteria")


'Search code
LastRow = Crit.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False

'Loop search code
For i = 2 To LastRow

    'Specialized Criteria1 Check
    If Crit.Range("F" & i) <> Crit.Range("G" & i) Or _
    Crit.Range("I" & i) <> Crit.Range("J" & i) Then

            'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
            Referrals.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Crit.Rows(i).Value

    End If

Next i
'End loop code

CoderBook.Close SaveChanges:=True
Application.ScreenUpdating = True

End Sub

Answer 1

Разделите или на два оператора:

For i = 2 To LastRow
    j = Referrals.Cells(Rows.Count, 1).End(xlUp).row + 1

    'Specialized Criteria1 Check
    If Crit.Range("F" & i) <> Crit.Range("G" & i) Then
        'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
        Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
        Referrals.Range("S" & j).Value = "Criteria1"
    End If
    If Crit.Range("I" & i) <> Crit.Range("J" & i) Then
        Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
        if Referrals.Range("S" & j).value = vbNullString then
            Referrals.Range("S" & j).Value = "Criteria2"
        Else
            Referrals.Range("S" & j).Value = Referrals.Range("S" & j).Value & ", " & "Criteria2"
    End if    
Next i