Фильтр в Excel VBA

Question

У меня есть цикл в VBA, который пропускает около 3000+ записей и скрывает те, которые не соответствуют критериям. Он работает отлично, но работает SUPER медленно. Существует ли более быстрый или эффективный способ фильтрации на основе следующих критериев? Любая помощь будет принята с благодарностью.

Dim i As Long, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, j As Long, sheetName As String, rng6 As Range, rng7 As Range, rng8 As Range, rng9 As Range 

Set rng1 = FindHeader("Client Exclusion List", Sheet8.Name) 
Set rng2 = FindHeader("CLIENT NAME", Sheet5.Name) 
Set rng3 = FindHeader("MARKET SEGMENT", Sheet5.Name) 
Set rng4 = FindHeader("ARCHIVED", Sheet5.Name) 
Set rng5 = FindHeader("FORMULARY NAME", Sheet5.Name) 
Set rng6 = FindHeader("WEBSITE", Sheet5.Name) 
Set rng7 = FindHeader("PDF", Sheet5.Name) 
Set rng8 = FindHeader("HPMS EXPORTED", Sheet5.Name) 
Set rng9 = FindHeader("SERFF EXPORTED", Sheet5.Name) 

For i = 1 To rng2.Rows.Count 
'Checks to see if the Client Name is in the Excluded list 
    For j = 1 To rng1.Rows.Count 

     If rng2.Cells(i, 1).Value = rng1.Cells(j, 1).Value Then 
      rng2.Cells(i, 1).EntireRow.Hidden = True 
     End If 

    Next j 

    'Checks For all CMS records and hides the ones that are not from current year 

    If Left(rng3.Cells(i, 1).Value, 8) = "CMS Part" Then 
     If rng3.Cells(i, 1).Value <> "CMS Part D (CY " & Year(Date) & ")" Then 
      rng3.Cells(i, 1).EntireRow.Hidden = True 
     End If 
    End If 
    'Checks if record is archived 
    If rng4.Cells(i, 1).Value = "Yes" Then 
     rng4.Cells(i, 1).EntireRow.Hidden = True 
    End If 
'Checks if record contains "Test" or "Demo" in the Name 
    If InStr(1, CStr(rng5.Cells(i, 1).Value), "test") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "Test") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "demo") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "Demo") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "TEST") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "DO NOT USE") > 0 Then 
     rng5.Cells(i, 1).EntireRow.Hidden = True 
    End If 

Next i 

Answer 1

Одно небольшое изменение, которое должно помочь в добавлении

Application.ScreenUpdating = False 

в начале и

Application.ScreenUpdating = True 

в конце

Время обновления экрана может быть гораздо более существенным, чем логика.

Редактировать как альтернатива циклу массива. Создает словарь, заполненный исключенными элементами, как ключи перед большим циклом. Множество было бы лучше здесь, так как у вас есть бесполезный предмет, чтобы идти с каждым ключом, но я не думаю, что у VBA есть такие.

Вместо того, чтобы проходить через диапазон или массив, вы просто проверяете наличие ключа в словаре.

'before loop 
    Dim excludedList As Object 
    Set excludedList = CreateObject("Scripting.Dictionary") 
    For i = 1 To rng1.Rows.Count 
     excludedList.Add rng1.Cells(i, 1).value, 1 
    Next i 

    '**************************************** 
    'in loop 
    If excludedList.exists(rng2.Cells(i, 1).Value) Then 
     rng2.Cells(i, 1).EntireRow.Hidden = True 
    End If 

Answer 2

Вот пример, который должен быть быстрее. Он использует массив, автофильтра и не обрабатывает все остальные диапазоны для каждого ряда rng2:

Dim rng1     As Range 
Dim rng2     As Range 
Dim rng3     As Range 
Dim rng4     As Range 
Dim rng5     As Range 
Dim rng6     As Range 
Dim rng7     As Range 
Dim rng8     As Range 
Dim rng9     As Range 
Dim i      As Long 
Dim j      As Long 
Dim sheetName    As String 
Dim vData1 

Set rng1 = FindHeader("Client Exclusion List", Sheet8.Name) 
Set rng2 = FindHeader("CLIENT NAME", Sheet5.Name) 
Set rng3 = FindHeader("MARKET SEGMENT", Sheet5.Name) 
Set rng4 = FindHeader("ARCHIVED", Sheet5.Name) 
Set rng5 = FindHeader("FORMULARY NAME", Sheet5.Name) 
Set rng6 = FindHeader("WEBSITE", Sheet5.Name) 
Set rng7 = FindHeader("PDF", Sheet5.Name) 
Set rng8 = FindHeader("HPMS EXPORTED", Sheet5.Name) 
Set rng9 = FindHeader("SERFF EXPORTED", Sheet5.Name) 

Application.ScreenUpdating = False 

vData1 = rng1.Value 

For i = 1 To rng2.Rows.Count 
    'Checks to see if the Client Name is in the Excluded list 
    For j = LBound(vdata1, 1) To UBound(vdata1, 1) 

     If rng2.Cells(i, 1).Value = vdata1(j, 1) Then 
      rng2.Cells(i, 1).EntireRow.Hidden = True 
      Exit For 
     End If 

    Next j 
Next i 

'Checks For all CMS records and hides the ones that are not from current year 

rng3.AutoFilter 1, "<>CMS Part*", xlOr, "CMS Part D (CY " & Year(Date) & ")" 
'Checks if record is archived 
rng4.AutoFilter 1, "<>Yes" 
'Checks if record contains "Test" or "Demo" in the Name 
rng5.AutoFilter 1, "<>*test*", xlAnd, "<>*demo*" 

Application.ScreenUpdating = True