多条件复制粘贴VBA代码优化求助：提升运行效率

我来帮你优化这段VBA代码，解决运行耗时久的问题！咱们先说说原代码慢的核心原因：逐个遍历单元格并频繁和Excel工作表交互——VBA和工作表对象的每次交互都有不小的开销，数据量稍微大一点就会明显拖慢速度。下面给你两个高效的优化方案，还有通用的提速技巧：

方案1：使用AutoFilter（推荐，简洁高效） #

AutoFilter是Excel内置的过滤功能，底层优化得很好，比手动循环快很多，代码也更简洁：

Private Sub CommandButton3_Click()
    ' 通用提速设置：关闭不必要的Excel功能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim sourceRange As Range
    Dim targetStartCell As Range
    Dim filterCol1 As Integer, filterCol2 As Integer
    Dim criteria1 As Variant, criteria2 As Integer
    
    ' 定义区域和条件
    Set sourceRange = Range("A2:R50") ' 包含需要过滤的所有数据列
    Set targetStartCell = Range("N6")
    filterCol1 = 2 ' B列，对应第一个条件列
    filterCol2 = 1 ' A列，对应月份所在列
    criteria1 = Range("O3").Value ' 第一个条件值
    criteria2 = Range("P3").Value ' 第二个条件：月份值（对应你原代码里的未完成部分）
    
    ' 清空目标区域
    Range("N6:R50").ClearContents
    
    ' 应用双条件过滤
    sourceRange.AutoFilter Field:=filterCol1, Criteria1:=criteria1
    sourceRange.AutoFilter Field:=filterCol2, Criteria1:=criteria2, Operator:=xlFilterValues, Criteria2:=Array(1, criteria2)
    
    ' 复制可见区域（注意跳过表头）
    On Error Resume Next ' 防止没有符合条件的数据时报错
    sourceRange.Offset(1, 13).Resize(sourceRange.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible).Copy targetStartCell
    On Error GoTo 0
    
    ' 取消过滤
    sourceRange.AutoFilter
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

说明：

• 这里假设你要复制的是B列匹配条件、A列月份符合要求的行里的N-R列数据，若列对应关系不对，可调整Offset(1,13)的参数
• 用SpecialCells(xlCellTypeVisible)直接获取过滤后的可见行，彻底避免手动循环

方案2：使用数组批量处理（内存操作，速度最快） #

把所有数据读入内存数组，在数组里完成条件判断，再把符合条件的数据一次性写入目标区域，全程几乎不跟工作表交互，速度拉满：

Private Sub CommandButton3_Click()
    ' 通用提速设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim sourceArr As Variant
    Dim targetArr As Variant
    Dim i As Integer, j As Integer, rowCount As Integer
    Dim criteria1 As Variant, criteria2 As Integer
    Dim matchCount As Integer
    
    ' 读取源数据到数组
    sourceArr = Range("A2:R50").Value
    rowCount = UBound(sourceArr, 1)
    criteria1 = Range("O3").Value
    criteria2 = Range("P3").Value ' 目标月份
    
    ' 先统计符合条件的行数，初始化目标数组
    matchCount = 0
    For i = 1 To rowCount
        If sourceArr(i, 2) = criteria1 And Month(sourceArr(i, 1)) = criteria2 Then
            matchCount = matchCount + 1
        End If
    Next i
    
    If matchCount > 0 Then
        ReDim targetArr(1 To matchCount, 1 To 5) ' 目标是5列（N-R）
        j = 0
        For i = 1 To rowCount
            If sourceArr(i, 2) = criteria1 And Month(sourceArr(i, 1)) = criteria2 Then
                j = j + 1
                ' 把对应列的数据存入目标数组（A-R里的N-R是第14到18列）
                targetArr(j, 1) = sourceArr(i, 14)
                targetArr(j, 2) = sourceArr(i, 15)
                targetArr(j, 3) = sourceArr(i, 16)
                targetArr(j, 4) = sourceArr(i, 17)
                targetArr(j, 5) = sourceArr(i, 18)
            End If
        Next i
        ' 一次性写入目标区域
        Range("N6").Resize(matchCount, 5).Value = targetArr
    Else
        Range("N6:R50").ClearContents
    End If
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

说明：

• 数组索引从1开始，sourceArr(i,2)对应原数据第i行B列，sourceArr(i,1)对应A列
• 先统计符合条件的行数再初始化数组，避免浪费内存

通用提速小技巧 #

不管用哪个方案，都建议加上开头的三行设置：

• Application.ScreenUpdating = False：关闭屏幕刷新，避免每次操作都刷新界面
• Application.EnableEvents = False：禁止触发工作表事件，防止干扰代码运行
• Application.Calculation = xlCalculationManual：暂时设置手动计算，避免每次修改数据都重新计算公式

操作完成后一定要恢复这些设置，不然会影响Excel的正常使用。

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