筛选表格字段后跨工作簿复制粘贴卡顿，求VBA代码优化方案

看来你的代码在处理大数据量时遇到了性能瓶颈和无响应问题，主要是因为逐行遍历可见区域、频繁使用Union合并区域，以及不必要的Activate/Select操作拖慢了速度。下面是优化后的代码，同时解决这些问题：

Sub FilterAndCopyData()
    Dim sourceTable As ListObject
    Dim visibleData As Range
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    
    ' 关闭屏幕更新和事件触发，大幅提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo Cleanup ' 错误捕获，确保Excel设置能正常恢复
    
    ' 绑定源数据表格对象
    Set sourceTable = Sheet2.ListObjects("DataTable")
    
    ' 清除之前的筛选状态（如果存在）
    If sourceTable.AutoFilter.FilterMode Then
        sourceTable.AutoFilter.ShowAllData
    End If
    
    ' 应用目标筛选条件
    sourceTable.Range.AutoFilter Field:=12, Criteria1:="DE"
    
    ' 获取筛选后的可见数据区域（自动排除表头）
    On Error Resume Next ' 处理无匹配数据的情况
    Set visibleData = sourceTable.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo Cleanup
    
    If Not visibleData Is Nothing Then
        ' 直接绑定目标工作簿和工作表，避免低效的Activate/Select操作
        Set targetWB = Workbooks("Land-DE.xlsx")
        Set targetWS = targetWB.Sheets("Overall view")
        
        ' 复制并粘贴值和格式
        visibleData.Copy
        targetWS.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        
        ' 清空剪贴板，释放内存
        Application.CutCopyMode = False
    Else
        MsgBox "没有找到符合条件的数据！", vbInformation
    End If

Cleanup:
    ' 恢复源表格的无筛选状态（可选，根据你的需求调整）
    If sourceTable.AutoFilter.FilterMode Then
        sourceTable.AutoFilter.ShowAllData
    End If
    
    ' 恢复Excel的正常设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    ' 如果有错误，弹出提示
    If Err.Number <> 0 Then
        MsgBox "运行出错：" & Err.Description, vbCritical
    End If
End Sub

核心优化点说明 #

• 关闭界面刷新与事件：ScreenUpdating和EnableEvents关闭后，Excel不会频繁刷新界面或触发多余事件，直接解决大数据量下的无响应问题。
• 抛弃Activate/Select：直接通过对象引用操作工作簿和工作表，这是VBA性能提升的关键——这类操作本身非常低效，尤其数据量越大影响越明显。
• 跳过逐行合并区域：原代码用Union逐行合并可见区域的方式极耗资源，优化后直接获取整个可见数据区域，一次性完成复制，效率提升数倍。
• 完善错误处理：确保即使运行出错，也能恢复Excel的正常状态，避免后续操作异常。

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