Excel VBA批量查找目标值后一次性复制数据避免工作表频繁切换

完全可以实现一次性读取所有目标数据后统一写入，不需要在工作表之间反复跳转，核心是放弃逐次Copy/Paste的操作逻辑，直接通过工作表对象的内存引用完成所有查找、取值操作，最后批量写入结果，性能会比你现在的写法高很多，也不会出现屏幕来回切换的问题。

核心优化逻辑 #

• 全程不使用Activate、Select切换工作表，所有操作基于提前绑定的工作表对象完成
• 弃用剪贴板相关的Copy、PasteSpecial方法，直接读取单元格的值和数字格式属性赋值，避免剪贴板占用和界面跳转
• 把你20多个独立的提取逻辑统一管理，不用维护大量重复的Sub过程
• 匹配失败时直接写入占位符，不需要额外操作工作表

实现代码 #

你原来写的Property过程（wsSrc、wSrc、col、col2、wsDest）可以全部保留，新增以下通用批量处理过程即可：

Sub BatchExtractAllTargets()
    ' === 配置区：在这里统一维护所有需要查找的指标和对应写入的目标列 ===
    Dim targetConfigs As Variant
    targetConfigs = Array( _
        Array("DSCR Analysis", "B"), _
        Array("Commercial Income", "E"), _
        Array("第一个新增指标关键词", "F"), _
        Array("第二个新增指标关键词", "G") _
        ' 剩余的指标按照上面的格式逐行添加即可
    )
    
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim searchColumn As Long, i As Long
    Dim foundCell As Range, destStart As Range
    Dim keyword As String, destColumn As String
    Dim sourceRng As Range
    
    ' 基础性能优化配置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 绑定对象，全程不需要激活任何工作表
    Set wsSource = wsSrc
    Set wsTarget = wsDest
    searchColumn = col
    
    ' 遍历所有配置的待提取指标
    For i = LBound(targetConfigs) To UBound(targetConfigs)
        keyword = targetConfigs(i)(0)
        destColumn = targetConfigs(i)(1)
        
        ' 查找逻辑和你原来的参数完全一致，保证匹配规则不变
        Set foundCell = wsSource.Columns(searchColumn).Find( _
            What:=keyword, _
            LookIn:=xlValues, _
            LookAt:=xlPart, _
            MatchCase:=False _
        )
        
        ' 定位目标列的下一个空写入位置
        Set destStart = wsTarget.Cells(wsTarget.Rows.Count, destColumn).End(xlUp).Offset(1, 0)
        
        If foundCell Is Nothing Then
            ' 未匹配到值，直接写入6个占位符
            destStart.Resize(6, 1).Value = "-"
        Else
            ' 直接读取源单元格右侧6个单元格的值和格式，转置后写入目标位置
            Set sourceRng = foundCell.Offset(0, 1).Resize(1, 6)
            destStart.Resize(6, 1).Value = Application.Transpose(sourceRng.Value)
            destStart.Resize(6, 1).NumberFormat = Application.Transpose(sourceRng.NumberFormat)
        End If
    Next i
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "提取完成，共处理 " & UBound(targetConfigs) + 1 & " 个指标"
End Sub

补充说明 #

• 如果你不需要把横向的6个值转成纵向排列，只要删除代码里的Application.Transpose()部分，同时把Resize(6, 1)改成Resize(1, 6)即可
• 目前的写法对于20个左右指标的场景已经足够流畅，如果后续需要处理上百个指标，可以进一步把所有待提取数据先装入二维内存数组，最后一次性写入目标表，能再提升数倍速度
• 原有的20多个独立提取过程（比如PasteCI）可以全部废弃，后续新增提取指标只要在配置区加一行配置即可，维护成本低很多

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