如何优化填充不连续列的VBA代码以提升运行效率

一、基础提速配置 #

VBA运行慢的核心原因之一是频繁与工作表交互、屏幕刷新和自动计算拖慢了执行速度，先加上这些必做的提速设置：

' 开启提速模式
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' 你的核心填充代码写在这里

' 恢复默认设置
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

这几步能直接让代码速度提升数倍，是所有VBA优化的基础操作。

二、简化代码+数组批量处理 #

针对你不连续列的填充需求，可以用数组批量读写数据，大幅减少单元格交互次数：

Sub OptimizedFill()
    Dim srcSheet As Worksheet
    Dim targetStartRow As Long
    Dim srcData As Variant
    ' 定义目标列与源列的对应关系
    Dim targetCols As Variant, srcCols As Variant
    
    ' 初始化对象和参数
    Set srcSheet = ThisWorkbook.Sheets(3) ' 替换为你的源表序号/名称
    targetStartRow = Range("namedrange").Row + 5
    targetCols = Array(1, 3, 5, 8)
    srcCols = Array(7, 8, 9, 10)
    
    ' 一次性读取源数据到数组（比逐个读取单元格快N倍）
    srcData = srcSheet.Range(srcSheet.Cells(4, 7), srcSheet.Cells(5, 10)).Value
    
    ' 开启提速设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 循环完成对应列的赋值
    Dim i As Integer
    For i = LBound(targetCols) To UBound(targetCols)
        Cells(targetStartRow, targetCols(i)).Value = srcData(1, i + 1)
        Cells(targetStartRow + 1, targetCols(i)).Value = srcData(2, i + 1)
    Next i
    
    ' 恢复默认设置
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

三、极致优化：一次性写入不连续区域 #

如果想彻底减少工作表交互次数，可以把所有目标单元格合并成一个Range，实现一次性赋值：

Sub EvenFasterFill()
    Dim srcSheet As Worksheet
    Dim targetStartRow As Long
    Dim srcData As Variant
    Dim targetRange As Range
    Dim targetCols As Variant
    Dim i As Integer
    
    Set srcSheet = ThisWorkbook.Sheets(3)
    targetStartRow = Range("namedrange").Row + 5
    targetCols = Array(1, 3, 5, 8)
    
    ' 读取源区域数据到数组
    srcData = srcSheet.Range(srcSheet.Cells(4, 7), srcSheet.Cells(5, 10)).Value
    
    ' 构建不连续的目标区域
    Set targetRange = Cells(targetStartRow, targetCols(0))
    For i = 1 To UBound(targetCols)
        Set targetRange = Union(targetRange, Cells(targetStartRow, targetCols(i)))
    Next i
    ' 加入第二行的目标单元格
    For i = LBound(targetCols) To UBound(targetCols)
        Set targetRange = Union(targetRange, Cells(targetStartRow + 1, targetCols(i)))
    Next i
    
    ' 开启提速设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 一次性完成所有赋值
    targetRange.Value = Application.Transpose(Application.Transpose(srcData))
    
    ' 恢复默认设置
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

优化逻辑说明 #

• 原代码每次赋值都要触发一次工作表交互，8次赋值对应8次交互；用数组后仅需1次读操作+少量写操作，交互次数骤减。
• 关闭屏幕更新和自动计算，避免VBA每次操作都刷新界面、重新计算公式，这是VBA提速的核心技巧。

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