Проверьте, существуют ли все значения столбца в другом списке

Question

Макрос excel vba, который я создал, проходит через весь столбец и ищет каждое значение в столбце по сравнению с другим столбцом, найденным на другом листе. У меня есть столбец T / F, где я отмечаю "T", если он найден, и "F", если он не найден. Тем не менее, я чувствую, что способ, которым я это делаю, может быть не очень эффективным, так как макросу требуется около 30 минут, чтобы просмотреть 31 000 строк значений для поиска в другом столбце с приблизительно 27 000 значений.

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

Первоначально столбец T / F будет пустым. Только после выполнения макроса он будет заполнен. Я перебираю каждую строку в столбце A и пытаюсь найти значение для SearchCol на следующем рисунке.

Вот код VBA, который я сейчас использую.

Sub CheckIfValuesExist()
    Dim ActiveWS As Worksheet, WS2 As Worksheet
    Dim ValueColLetter As String, SearchColLetter As String, TFColLetter As String
    Dim LastRow As Long, i As Long
    Dim target As Variant, rng As Range

    Set ActiveWS = ActiveWorkbook.Worksheets(1)
    Set WS2 = ActiveWorkbook.Worksheets(2)
    ValueColLetter = "A"
    SearchColLetter = "A"
    TFColLetter = "B"
    LastRow = ActiveWS.Cells.Find(What:="*", SearchOrder:=xlRows, _
               SearchDirection:=xlPrevious, _
               LookIn:=xlFormulas).Row

    For i = 2 To LastRow
        target = ActiveWS.Range(ValueColLetter & i).Value
        If target <> "" Then
            With WS2.Range(SearchColLetter & ":" & SearchColLetter) 'searches all of column A
                Set rng = .Find(What:=target, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                If Not rng Is Nothing Then
                    ActiveWS.Range(TFColLetter & i).Value = "T" 'value found
                Else
                    ActiveWS.Range(TFColLetter & i).Value = "F" 'value not found
                End If
            End With
        End If
    Next i
End Sub

Макрос работает как задумано, я просто нахожу его медленным. Есть ли лучший способ сделать то же самое, но более быстрым способом?

Answer 1

Почему вы не используете формулу MATCH?

Если ваши значения указаны в столбце A, а значения для поиска - в ячейки $ F $ 5: $ F $ 10, формула:

= ПОИСКПОЗ (A2, $ F $ 5: $ F $ 10,0)

или если вы настаиваете на результате T / F:

= ЕСЛИ (ЕОШИБКА (MATCH (А2, $ F $ 5: $ F $ 10,0)), "Т", "Р")

Конечно, вы можете вставить эту формулу также с помощью макроса.

Answer 2

Проверить столбец по отношению к столбцу

Диапазон совпадений массива Версия

Sub CheckIfValuesExist()

    Const cSheet1 As Variant = 1  ' Value Worksheet Name/Index
    Const cSheet2 As Variant = 2  ' Search Worksheet Name/Index
    Const cFirst As Long = 2      ' First Row
    Const cVal As Variant = "A"   ' Value Column
    Const cSrc As Variant = "A"   ' Search Column
    Const cTF As Variant = "B"    ' Target Column
    Const cT As String = "T"      ' Found String
    Const cF As String = "F"      ' Not Found String

    Dim RngS As Range     ' Search Range
    Dim vntV As Variant   ' Value Array
    Dim vntT As Variant   ' Target Array
    Dim LastV As Long     ' Value Last Column Number
    Dim LastS As Long     ' Search Last Column Number
    Dim i As Long         ' Value/Target Row Counter
    Dim dummy As Long     ' Match Dummy Variable

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    On Error GoTo ProcedureExit

    With ThisWorkbook.Worksheets(cSheet1)
        LastV = .Columns(.Cells(1, cVal).Column).Find("*", , -4123, , 2, 2).Row
        vntV = .Range(.Cells(cFirst, cVal), .Cells(LastV, cVal))
    End With

    With ThisWorkbook.Worksheets(cSheet2)
        LastS = .Columns(.Cells(1, cSrc).Column).Find("*", , -4123, , 2, 2).Row
        Set RngS = .Range(.Cells(cFirst, cSrc), .Cells(LastS, cSrc))
        ReDim vntT(1 To UBound(vntV), 1 To 1)
        For i = 1 To UBound(vntV)
            On Error Resume Next
            If vntV(i, 1) <> "" Then
                dummy = Application.Match(vntV(i, 1), RngS, 0)
                If Err Then
                    vntT(i, 1) = cF
                  Else
                    vntT(i, 1) = cT
                End If
            End If
            On Error GoTo 0
        Next
    End With

    On Error GoTo ProcedureExit

    With ThisWorkbook.Worksheets(cSheet1)
        .Range(.Cells(cFirst, cTF), .Cells(.Rows.Count, cTF)).ClearContents
        .Cells(cFirst, cTF).Resize(UBound(vntT)) = vntT
    End With

ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Answer 3

Предположим, что данные включены в лист 1.

Попробуйте:

    Option Explicit

    Sub VlookUp()

        Dim LastRowSV As Long, LastRowV As Long, Counts As Long
        Dim wsName As String
        Dim wsListSV As Range, cellSV As Range, wsListV As Range, cellV As Range

        With ThisWorkbook.Worksheets("Sheet1")

            'Find the last row of Search Values
            LastRowSV = .Cells(.Rows.Count, "D").End(xlUp).Row
            'Find the last row of Values
            LastRowV = .Cells(.Rows.Count, "A").End(xlUp).Row

            'Set the list with the Search Values
            Set wsListSV = .Range(Cells(2, 4), Cells(LastRowSV, 4))
            'Set the list with the Values
            Set wsListV = .Range(Cells(3, 1), Cells(LastRowV, 1))

            'Loop each value in Search Values
            For Each cellV In wsListV
                Counts = Application.WorksheetFunction.CountIf(wsListSV, cellV)
                If Counts <> 0 Then
                    cellV.Offset(0, 1).Value = "T"
                Else
                    cellV.Offset(0, 1).Value = "F"
                End If

            Next

        End With

    End Sub

Результат: