Как вы передаете ячейку или диапазон в InStr?

Question

Я пытаюсь скопировать строки с одного листа на другой, основываясь на том, существует ли строка в указанной ячейке c каждой строки. В приведенном ниже примере я ищу Иорданию в столбце J. Если это имя находится в столбцах J этой конкретной строки, оно перемещается на другой лист (Финальный лист).

Sub Test()
Worksheets("All Data").Activate

Dim N As Long, i As Long
    N = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To N
        If InStr(1, Cells(i, "J"), "Jordan") > 0 Then
            Worksheets("All Data").Rows(i).Copy
            Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next i
End Sub

Что я хочу чтобы сделать, это искать несколько строк. Я могу выполнить это sh, добавив столько «И», как показано ниже.

If InStr(1, Cells(i, "J"), "Jordan") > 0 Or InStr(1, Cells(i, "J"), "Barkley") > 0 Then

У меня обычно есть 5+ строк, которые я ищу, и каждый раз становится трудно обновлять код. Я бы предпочел, чтобы строки, которые я ищу, были бы расположены в диапазоне ячеек на каком-то скрытом листе, который я или кто-то мог бы легко обновить. Я возился с нижеследующим. Диапазон действительно работает, если это одна ячейка. Если его больше, например, A1: A5, то он ломается. Любые мысли о том, как я мог сделать это? Мне не хватает элегантного решения?

Sub Test()
Worksheets("All Data").Activate

Dim N As Long, i As Long
    N = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To N
        If InStr(1, Cells(i, "J"), Worksheets("List").Range("A1:A5")) > 0 Then
            Worksheets("All Data").Rows(i).Copy
            Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next i
End Sub

List Sheet
- |    A    |
1 | Jordan  |
2 | Barkley |
3 | Batman  |
4 | Robin   |
5 | Ozzy    |

Answer 1

Исходя из этого предыдущего ответа , я настраиваю его в соответствии с вашим сценарием

Не забудьте сделать резервную копию ваших данных перед запуском.

Прочитайте комментарии кода и настройте переменные 'значения, соответствующие вашим потребностям.

Public Sub CopyData()

    ' Define the object variables
    Dim sourceWorksheet As Worksheet
    Dim targetWorksheet As Worksheet

    Dim listRange As Range
    Dim evalCell As Range

    ' Define other variables
    Dim listRangeAddress As String

    Dim startSourceRow As Long
    Dim lastSourceRow As Long
    Dim columnForLastRowSource As Long

    Dim lastTargetRow As Long
    Dim sourceRowCounter As Long
    Dim columnForLastRowTarget As Long

    Dim columnToEval As Long


    ''''' Adjust the folloing values ''''

    ' Set the lookup list range address
    listRangeAddress = "B1:B5"

    ' Adjust the worksheets names
    Set sourceWorksheet = ThisWorkbook.Worksheets("All Data")
    Set targetWorksheet = ThisWorkbook.Worksheets("Final Sheet")
    Set listRange = ThisWorkbook.Worksheets("List").Range(listRangeAddress)

    ' Set the initial row where data is going to be evaluated
    startSourceRow = 1

    ' Set the column from which you're going to get the last row in sourceSheet
    columnForLastRowSource = 1

    ' Set the column from which you're going to get the last row in targetSheet
    columnForLastRowTarget = 1

    ' Set the column where you evaluate if condition is met
    columnToEval = 10



    '''''''Loop to copy rows that match'''''''

    ' Find the number of the last row in source sheet
    lastSourceRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnForLastRowSource).End(xlUp).Row

    For sourceRowCounter = startSourceRow To lastSourceRow

        For Each evalCell In listRange.Cells

            ' Evaluate if criteria is met in column
            If InStr(sourceWorksheet.Cells(sourceRowCounter, columnToEval).Value, evalCell.Value) > 0 Then

                ' Get last row on target sheet (notice that this search in column A = 1)
                lastTargetRow = targetWorksheet.Cells(targetWorksheet.Rows.Count, columnForLastRowTarget).End(xlUp).Row

                ' Copy row to target
                sourceWorksheet.Rows(sourceRowCounter).Copy targetWorksheet.Rows(lastTargetRow + 1)

                ' If found, don't keep looking
                Exit For

            End If

        Next evalCell

    Next sourceRowCounter

End Sub

Дайте мне знать, если это работает, и не забудьте пометить ответ, если это так.