Hide not matching criteria rows on the visible rows only is very slow, although using arrays

Question

I need to Filter/Show data on the visible cells only on my dataset.
The using of AutoFilter is very fast, But it has a downside that it show any hidden rows on the respective criteria. .
Although I am using arrays and Application optimization on the below code , but it gets very slow if the range starts to be bigger.
With just 100 rows, it finished on 1.12 sec and with 1000 rows it finished on 117.47 sec !
In advance, I am grateful for all your support.

Option Explicit
Option Compare Text
 
Sub Filter_on_Visible_Cells_Only()
 
   Dim t: t = Timer
 
   Dim ws1 As Worksheet, ws2 As Worksheet
   Dim rng1 As Range, rng2 As Range
   Dim arr1() As Variant, arr2() As Variant
   Dim i As Long, HdRng As Range
   Dim j As Long, k As Long
 
   SpeedOn
 
   Set ws1 = ThisWorkbook.ActiveSheet
   Set ws2 = ThisWorkbook.Sheets("Platforms")
 
    Set rng1 = ws1.Range("D3:D" & ws1.Cells(Rows.Count, "D").End(xlUp).Row)     'ActiveSheet
    Set rng2 = ws2.Range("B3:B" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)     'Platforms
 
    arr1 = rng1.Value2
    arr2 = rng2.Value2
 
   For i = 1 To UBound(arr1)
 
    If ws1.Rows(i + 2).Hidden = False Then                       '(i + 2) because Data starts at Row_3
 
    For j = LBound(arr1) To UBound(arr1)
    For k = LBound(arr2) To UBound(arr2)
 
      If arr1(j, 1) <> arr2(k, 1) Then
 
         addToRange HdRng, ws1.Range("A" & i + 2)                'Make a union range of the rows NOT matching criteria...
 
      End If
 
      Next k
     Next j
    End If
  Next i
 
      If Not HdRng Is Nothing Then HdRng.EntireRow.Hidden = True      'Hide not matching criteria rows.
 
    Speedoff
 
   Debug.Print "Filter_on_Visible_Cells, in " & Round(Timer - t, 2) & " sec"
 
End Sub
 
Private Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub
 
Sub SpeedOn()
    With Application
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .EnableEvents = False
       .DisplayAlerts = False
    End With
End Sub
Sub Speedoff()
    With Application
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
      .EnableEvents = True
      .DisplayAlerts = True
    End With
End Sub

Answer 1

Ok, if you want to use this, you have to use the autofilter with vba as well. There is no event which fires on usage of the autofilter through the excel UI (except you work with some help of formulas in hidden worksheets, like described here Link).

But if you want to use it in vba, you could simply use this, this should help and if i try it on that 167 cells, it works pretty fast:

Sub m()
    Dim rngTemp As Range
    For Each c In Range("a1:a167")
        If c.EntireRow.Hidden Then
            If rngTemp Is Nothing Then
                Set rngTemp = c
            Else
                Set rngTemp = Union(rngTemp, c)
            End If
        End If
    Next c
    
    Range("A1:A167").AutoFilter Field:=1, Criteria1:="10"   ' your autofilter values
    
    rngTemp.EntireRow.Hidden = False
    
End Sub

Answer 2

Compare Values Using Application.Match

Sub Filter_on_Visible_Cells_Only()
 
    Dim t: t = Timer
    
    Dim sws As Worksheet, srg As Range
    Dim dws As Worksheet, drg As Range, dCell As Range, hdrg As Range
    
    SpeedOn
    
    Set sws = ThisWorkbook.Sheets("Platforms")
    Set srg = sws.Range("B3", sws.Cells(sws.Rows.Count, "B").End(xlUp))
    
    Set dws = ThisWorkbook.ActiveSheet
    Set drg = dws.Range("D3", dws.Cells(dws.Rows.Count, "D").End(xlUp))
    Set drg = drg.SpecialCells(xlCellTypeVisible)
    
    For Each dCell In drg.Cells
        If IsError(Application.Match(drg.Value, srg, 0)) Then
            addToRange hdrg, dCell
        End If
    Next dCell
    
    If Not hdrg Is Nothing Then hdrg.EntireRow.Hidden = True
    
    Speedoff
    
    Debug.Print "Filter_on_Visible_Cells, in " & Round(Timer - t, 2) & " sec"
 
End Sub