Excel VBA筛选后F列数据同步至G列性能优化需求

现有ScrubbingOptimized宏可实现筛选后将F列可见数据同步至G列，但数据量较大时运行卡顿。需求为设置筛选条件后，将F列不含表头的可见数据填充至对应行的G列；曾尝试复制粘贴、模拟Ctrl+Shift+Down选范围的方案，均无法实现G列与F列单元格的对应匹配。

现有VBA代码如下：

Sub ScrubbingOptimized()
    Dim LastRow As Long
    Dim FilteredDataRange As Range
    Dim Cell As Range
    
    ' Disable screen updating to improve performance
    Application.ScreenUpdating = False
    
    ' Find the last row in column A (assuming it contains the data)
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Apply the filter criteria to column AB (Field 24)
    ActiveSheet.Range("$A$1:$AB$" & LastRow).AutoFilter Field:=24, Criteria1:="=No", Operator:=xlOr, Criteria2:=""
    
    ' Apply the filter criteria to column G (Field 7)
    ActiveSheet.Range("$A$1:$AB$" & LastRow).AutoFilter Field:=7, Criteria1:=Array( _
        "ALL SUPERVISORS", "IN-PLANT SUPPORT", "MAIN DISTRIBUTION TOUR-I", _
        "MAIN DISTRIBUTION TOUR-II", "MAIN DISTRIBUTION TOUR-III", _
        "MAINTENANCE OPERATIONS"), Operator:=xlFilterValues
    
    ' Find the first cell with filtered data in column F (excluding header)
    Set FilteredDataRange = Columns("F").SpecialCells(xlCellTypeVisible)
    
    If Not FilteredDataRange Is Nothing Then
        ' Loop through each visible cell in column F
        For Each Cell In FilteredDataRange
            ' Fill right in column G for the current cell in column F
            Cell.Offset(0, 1).Resize(1, Cell.MergeArea.Cells.Count).Value = Cell.Value
        Next Cell
    End If
    
    ' Clear the filters
    ActiveSheet.AutoFilterMode = False
    
    ' Re-enable screen updating
    Application.ScreenUpdating = True
End Sub

核心问题分析 #

原代码卡顿的根源是逐个循环可见单元格，大数量级下单单元格操作的IO开销会被急剧放大；同时代码未明确排除表头行，存在误处理风险；复制粘贴或模拟快捷键方案失效，是因为筛选后的可见区域非连续，常规范围选取无法精准匹配对应行。

优化后的代码 #

Sub ScrubbingOptimized_Fast()
    Dim LastRow As Long
    Dim FilteredDataRange As Range
    Dim ws As Worksheet
    Dim dataArea As Range
    Dim area As Range
    
    ' 开启全量性能优化
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set ws = ActiveSheet
    ' 基于A列确定数据边界
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set dataArea = ws.Range("A1:AB" & LastRow)
    
    ' 应用筛选规则
    dataArea.AutoFilter Field:=24, Criteria1:="=No", Operator:=xlOr, Criteria2:=""
    dataArea.AutoFilter Field:=7, Criteria1:=Array( _
        "ALL SUPERVISORS", "IN-PLANT SUPPORT", "MAIN DISTRIBUTION TOUR-I", _
        "MAIN DISTRIBUTION TOUR-II", "MAIN DISTRIBUTION TOUR-III", _
        "MAINTENANCE OPERATIONS"), Operator:=xlFilterValues
    
    ' 仅选取F列数据行（排除表头）的可见区域，处理无匹配数据的异常
    On Error Resume Next
    Set FilteredDataRange = ws.Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not FilteredDataRange Is Nothing Then
        ' 按连续区域批量赋值，大幅提升效率，同时适配合并单元格
        For Each area In FilteredDataRange.Areas
            area.Offset(0, 1).Value = area.Value
        Next area
    End If
    
    ' 清除筛选
    ws.AutoFilterMode = False
    
    ' 恢复应用默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

关键改进说明 #

• 批量区域操作：将逐个单元格循环改为按Areas（连续可见块）批量处理，把IO操作次数从几千/几万次降到几次，性能提升明显
• 精准范围选取：直接从F2开始选取可见区域，彻底避免表头被误同步
• 全量性能开关：额外关闭事件触发和自动计算，消除不必要的后台开销
• 合并单元格适配：通过Areas遍历自然匹配合并单元格的范围，确保G列对应位置正确填充

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