优化Excel VBA复制粘贴宏的读写速度方案咨询

针对第三方软件每秒多次写入Sheet1导致宏资源占用过高的问题，以下是具体优化思路和代码：

核心优化点 #

• 减少工作表重复引用：提前把Sheet1和Data表赋值给变量，避免每次操作都重新查找工作表
• 快速定位最后行：用Range.End(xlUp)替代遍历10000行，瞬间找到Data表的有效数据最后一行
• 批量数据写入：将需要复制的数据先存入数组，一次性写入Data表，大幅减少单元格IO操作（这是性能提升的关键）
• 优化事件触发逻辑：保留原始Target参数，避免重设导致的无效判断，只在关键区域变化时执行逻辑
• 提前判断过滤条件：把E2<>""、F2=""、AB5="35"的判断提到循环外，避免重复判断
• 关闭Excel冗余UI操作：临时关闭屏幕刷新、自动计算，减少资源消耗

优化后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 性能优化开关：关闭屏幕刷新、自动计算、事件
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    Dim wsSource As Worksheet, wsDest As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsDest = ThisWorkbook.Worksheets("Data")

    ' 定义关键监控区域，只有该区域变化才执行后续逻辑
    Dim keyRange As Range
    Set keyRange = wsSource.Range("A1:P50")
    ' 仅当变化区域和关键区域相交，且列数为16时继续（保留原逻辑）
    If Target.Columns.Count <> 16 Or Application.Intersect(Target, keyRange) Is Nothing Then
        GoTo Cleanup ' 直接跳转到恢复设置
    End If

    ' 提前判断过滤条件，不满足直接退出
    If wsSource.Range("E2") = "" Or wsSource.Range("F2") <> "" Or wsSource.Range("AB5") <> "35" Then
        GoTo Cleanup
    End If

    ' 统计需要复制的行数（替代原循环，用CountA更高效）
    Dim rowCount As Integer
    rowCount = Application.WorksheetFunction.CountA(wsSource.Range("A5:A12"))
    If rowCount = 0 Then GoTo Cleanup ' 无数据可复制直接退出

    ' 找到Data表的起始写入行
    Dim startRow As Long
    startRow = wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Row + 1

    ' 定义存储数据的数组，大小为需要复制的行数×22列
    Dim dataArr() As Variant
    ReDim dataArr(1 To rowCount, 1 To 22)

    ' 填充数组
    Dim i As Integer, c As Integer
    c = 5
    For i = 1 To rowCount
        ' 固定值（每行都一样的）
        dataArr(i, 1) = wsSource.Cells(3, 14).Value
        dataArr(i, 2) = wsSource.Cells(2, 2).Value
        dataArr(i, 3) = wsSource.Cells(1, 1).Value
        dataArr(i, 4) = wsSource.Cells(2, 5).Value
        dataArr(i, 11) = wsSource.Cells(3, 2).Value
        ' 每行变化的内容
        dataArr(i, 5) = wsSource.Cells(c, 26).Value
        dataArr(i, 6) = wsSource.Cells(c, 1).Value
        dataArr(i, 7) = wsSource.Cells(c, 6).Value
        dataArr(i, 8) = wsSource.Cells(c, 8).Value
        dataArr(i, 9) = wsSource.Cells(c, 15).Value
        dataArr(i, 10) = wsSource.Cells(c, 16).Value
        dataArr(i, 12) = wsSource.Cells(c, 7).Value
        dataArr(i, 13) = wsSource.Cells(c, 2).Value
        dataArr(i, 14) = wsSource.Cells(c, 3).Value
        dataArr(i, 15) = wsSource.Cells(c, 4).Value
        dataArr(i, 16) = wsSource.Cells(c, 5).Value
        dataArr(i, 17) = wsSource.Cells(c, 9).Value
        dataArr(i, 18) = wsSource.Cells(c, 12).Value
        dataArr(i, 19) = wsSource.Cells(c, 13).Value
        dataArr(i, 20) = wsSource.Cells(c, 10).Value
        dataArr(i, 21) = wsSource.Cells(c, 11).Value
        dataArr(i, 22) = wsSource.Cells(c, 25).Value
        c = c + 1
    Next i

    ' 一次性写入数组到Data表，大幅提升速度
    wsDest.Cells(startRow, 1).Resize(rowCount, 22).Value = dataArr

Cleanup:
    ' 恢复Excel设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

额外建议 #

• 如果第三方软件写入频率极高（比如每秒5次以上），可以考虑添加时间间隔判断，比如记录上次执行时间，仅当间隔超过500ms才执行复制逻辑，避免短时间内重复触发
• 尽量避免在Worksheet_Change中执行大量操作，如果允许，可考虑改用Worksheet_Calculate或者定时触发的宏（比如用Application.OnTime）

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