优化VBA宏：从主工作簿筛选数据并跨工作簿粘贴

问题背景 #

拥有含25个工作表的Master Workbook，需基于同一输入条件筛选其中10个工作表，将筛选结果复制到当前Active Workbook对应的10个工作表中。当前录制的宏大量使用Select语句，运行效率极低且代码僵化，难以维护。

原始录制宏代码 #

Sheets("AR Tasks (H)").Select
Range("E1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.ClearContents
Range("E1").Select

'Activates Dashboard master, filters tab, and copies data
Windows("Dashboard Macro Master.xlsx").Activate
Sheets("AR Tasks (H)").Select
ActiveSheet.Range("$A$1:$AB$1236").AutoFilter Field:=1, Criteria1:= _
    "PB Charlotte"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A1:AB1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

'Returns to macro worksheet and pastes data'
Windows("Dashboard Pivots Office by Office Master Macro.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("E1").Select
Selection.End(xlToLeft).Select

优化后的代码 #

Sub FilterAndCopyData()
    '声明对象变量
    Dim masterWB As Workbook
    Dim targetWB As Workbook
    Dim masterWS As Worksheet
    Dim targetWS As Worksheet
    Dim visibleData As Range
    Dim wsNames As Variant
    Dim criteria As String
    Dim i As Integer
    
    '设置常量：要处理的工作表列表、筛选条件
    wsNames = Array("AR Tasks (H)", "表2", "表3", "表4", "表5", "表6", "表7", "表8", "表9", "表10") '替换为实际10个工作表名
    criteria = "PB Charlotte" '替换为你的输入条件
    
    '关闭屏幕刷新、事件，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '定义工作簿对象，避免使用Activate/Select
    Set targetWB = ActiveWorkbook
    On Error Resume Next '防止主工作簿未打开报错
    Set masterWB = Workbooks("Dashboard Macro Master.xlsx")
    On Error GoTo 0
    
    If masterWB Is Nothing Then
        MsgBox "主工作簿 Dashboard Macro Master.xlsx 未打开，请先打开！"
        GoTo Cleanup
    End If
    
    '循环处理每个目标工作表
    For i = LBound(wsNames) To UBound(wsNames)
        '获取源表和目标表对象
        Set masterWS = masterWB.Worksheets(wsNames(i))
        Set targetWS = targetWB.Worksheets(wsNames(i))
        
        '清空目标表数据范围（从E1开始的已使用区域）
        With targetWS
            If Not .Range("E1").CurrentRegion Is Nothing Then
                .Range("E1").CurrentRegion.ClearContents
            End If
        End With
        
        '清除源表原有筛选，重新应用筛选
        masterWS.AutoFilterMode = False
        With masterWS.Range("A1").CurrentRegion
            .AutoFilter Field:=1, Criteria1:=criteria
            '获取筛选后的可见单元格（包含表头）
            On Error Resume Next
            Set visibleData = .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            
            If Not visibleData Is Nothing Then
                '直接将值赋值到目标表，比复制粘贴更快
                targetWS.Range("A1").Resize(visibleData.Rows.Count, visibleData.Columns.Count).Value = visibleData.Value
            End If
        End With
        '清除源表筛选
        masterWS.AutoFilterMode = False
    Next i
    
Cleanup:
    '恢复系统设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    '释放对象变量
    Set masterWB = Nothing
    Set targetWB = Nothing
    Set masterWS = Nothing
    Set targetWS = Nothing
    MsgBox "数据处理完成！"
End Sub

优化说明 #

• 移除Select/Activate：直接使用对象变量操作工作簿、工作表和单元格，避免界面切换，大幅提升运行速度
• 批量处理工作表：通过数组存储要处理的10个工作表名，循环遍历，避免重复代码，降低维护成本
• 动态获取数据范围：使用CurrentRegion代替硬编码的固定范围，自动适配数据量变化
• 直接赋值代替复制粘贴：通过.Value = .Value的方式传递数据，比Copy/PasteSpecial效率更高
• 优化运行环境：关闭屏幕刷新和事件触发，减少资源消耗
• 错误处理：增加主工作簿未打开的判断，避免代码崩溃
• 代码结构化：使用注释和模块化结构，提升代码可读性

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