Проверьте, содержит ли содержимое ячейки строку из списка

Question

Я работаю с отчетами, которые содержат конкурентные данные, и пытаюсь удалить любую строку, где ячейка в столбце D не соответствует списку строк, указанных на другом листе.Это то, что у меня есть, и пока оно работает, оно невероятно медленно.Есть ли более быстрый или более эффективный способ сделать это?

Dim product As String
Dim TempArray as Variant
Dim idArray() As Variant
Dim myTable As ListObject


Sub rambler()

    Application.ScreenUpdating = False
    populatingArrays
    filterID
    Application.ScreenUpdating = True

End Sub


Sub populatingArrays()

    Sheets("Competitive Set").Activate
    Set myTable = ActiveSheet.ListObjects("Table1")
    TempArray = myTable.DataBodyRange.Columns(1)
    idArray = Application.Transpose(TempArray)

End Sub

Sub filterID()

    Sheets("Report").Activate
    ActiveSheet.Range("D2").Activate

        Do While ActiveCell.Value <> ""
          product = ActiveCell.Value
          IsInArray = UBound(Filter(idArray, product))

          If UBound(Filter(idArray, product)) < 0 Then
             ActiveCell.EntireRow.Delete
           Else
             Selection.Offset(1, 0).Select
          End If

        Loop

    ActiveSheet.Name = "I&D Data"
    ActiveSheet.Range("A1").Select

End Sub

ПРИМЕЧАНИЯ. Я знаю, что не должен использовать Activate and Select, но я не уверен, как заставить это работать без них.Другое дело, что этот код частично вставлен при копировании, и я не уверен, что означает или делает IsInArray, но все строки удаляются, когда я удаляю эту строку.

Answer 1

Во-первых, я не вижу причины использовать глобальные переменные.Давайте добавим их в соответствующие подпрограммы.

Во-вторых, предположим, что на вашем листе «Отчет» есть данные в D2:D100, где ячейка D101 является первой пустой ячейкой.Таким образом, вы пытаетесь перебрать диапазон от D2 до D100 и проверяете, применяется ли фильтр.

В-третьих, я передаю аргументы подпрограммам, чтобы сохранить области как можно более локальными.(Я также делаю это без тестирования, но я думаю, что это должно работать ...)

Если это правильно, я думаю, что это должно работать быстрее для вас:

Option Explicit 'Forces you to declare all variables. This goes at the very top of the Module.
Sub rambler()
dim myArr as Variant
    Application.ScreenUpdating = False
    myArr = populatingArrays
    filterID(myArr)
    Application.ScreenUpdating = True
End Sub

Function populatingArrays() as Variant
Dim idArray() As Variant
Dim TempArray As Variant

    Set myTable = Sheets("Competitive Set").ListObjects("Table1")
    TempArray = myTable.DataBodyRange.Columns(1)
    idArray = Application.Transpose(TempArray)
    populatingArrays = idArray

End Sub

Sub filterID(arr as Variant)
Dim product As String
Dim myTable As ListObject
Dim lastRow As Long, i As Long

With Sheets("Report")
    lastRow = .Cells(Rows.Count, "D").End(xlUp).Row
    For i = lastRow To 1 Step -1 ' Deleting rows: it's best to start at the end and work up.
          product = .Cells(i, "D").Value
          IsInArray = UBound(Filter(arr, product))

          If IsInArray < 0 Then
             .Rows(i).EntireRow.Delete
          End If
    Next i
    .Name = "I&D Data"
End Sub

Редактировать:Посмотрите, сможете ли вы понять, как я удалил использование .Select.Кроме того, одна важная вещь для изучения / понимания - как передать параметр в подпрограмму.Я также изменил Sub populatingArrays() на Function, что позволяет нам возвращать некоторое значение (тогда как для Sub, для того же, вам понадобится глобальная переменная).Выполнение этого с помощью F8 должно помочь понять, как это работает.