仅在可见行筛选数据的VBA代码性能优化求助

问题背景 #

• 需求：仅对数据集的可见单元格执行筛选/显示操作
• 痛点：Excel原生AutoFilter速度快，但会显示原本隐藏的行；现有VBA代码虽用数组+应用程序优化，但数据量增大时性能骤降——100行耗时1.12秒，1000行耗时117.47秒

原代码 #

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

原代码核心问题 #

1. 三重嵌套循环：时间复杂度为O(n²*m)，数据量增大时性能指数级下降
2. 错误逻辑：内层循环中只要存在一组不匹配值就添加行到隐藏范围，导致同一行被重复添加多次，完全不符合筛选逻辑
3. 频繁Range操作：反复调用Union合并单元格，每次操作都会触发Excel内部计算，拖慢速度

优化后的代码 #

Option Explicit
Option Compare Text

Sub Filter_Visible_Cells_Optimized()
    Dim t As Double: t = Timer
    
    Dim wsData As Worksheet, wsPlatforms As Worksheet
    Dim rngData As Range, rngPlatforms As Range
    Dim arrData As Variant, arrPlatforms As Variant
    Dim dictPlatforms As Object
    Dim i As Long, lastRowData As Long, lastRowPlatforms As Long
    Dim hiddenRows As String
    
    ' 启用性能优化
    SpeedOn
    
    ' 初始化工作表对象
    Set wsData = ThisWorkbook.ActiveSheet
    Set wsPlatforms = ThisWorkbook.Sheets("Platforms")
    
    ' 获取数据范围
    lastRowData = wsData.Cells(Rows.Count, "D").End(xlUp).Row
    lastRowPlatforms = wsPlatforms.Cells(Rows.Count, "B").End(xlUp).Row
    
    Set rngData = wsData.Range("D3:D" & lastRowData)
    Set rngPlatforms = wsPlatforms.Range("B3:B" & lastRowPlatforms)
    
    ' 加载数据到数组
    arrData = rngData.Value2
    arrPlatforms = rngPlatforms.Value2
    
    ' 把Platforms数据存入字典，实现O(1)查找
    Set dictPlatforms = CreateObject("Scripting.Dictionary")
    For i = LBound(arrPlatforms) To UBound(arrPlatforms)
        If Not dictPlatforms.Exists(arrPlatforms(i, 1)) Then
            dictPlatforms.Add arrPlatforms(i, 1), True
        End If
    Next i
    
    ' 遍历可见行，收集需要隐藏的行号
    For i = LBound(arrData) To UBound(arrData)
        ' 仅处理可见行
        If Not wsData.Rows(i + 2).Hidden Then
            ' 如果当前行D列值不在Platforms中，标记为需要隐藏
            If Not dictPlatforms.Exists(arrData(i, 1)) Then
                If hiddenRows = "" Then
                    hiddenRows = CStr(i + 2)
                Else
                    hiddenRows = hiddenRows & "," & CStr(i + 2)
                End If
            End If
        End If
    Next i
    
    ' 一次性隐藏所有需要隐藏的行
    If hiddenRows <> "" Then
        wsData.Range("A" & hiddenRows).EntireRow.Hidden = True
    End If
    
    ' 恢复Excel设置
    Speedoff
    
    Debug.Print "Filter_Visible_Cells_Optimized, in " & Round(Timer - t, 2) & " sec"
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

优化说明 #

1. 字典优化查找：将Platforms表的B列数据存入字典，把原本O(m)的查找操作降为O(1)，彻底消除嵌套循环的性能瓶颈
2. 简化循环逻辑：仅遍历一次数据行，时间复杂度降至O(n)，数据量越大性能提升越明显
3. 批量操作Range：先收集需要隐藏的行号，最后一次性执行隐藏操作，避免频繁操作Range对象带来的开销
4. 修正筛选逻辑：仅当可见行的D列值不在Platforms表中时，才标记为需要隐藏，符合需求预期

内容的提问来源于stack exchange，提问作者Waleed