Excel VBA大数组写入表格初始速度慢的原因及优化问询

测试设置 #

• 34列1行的空Excel表格（ListObject）
• 生成包含随机数的10000行34列Variant数组，首次写入表格耗时37秒
• 生成新的同规格数组，追加至表格末尾仅耗时1.5秒，后续每次追加耗时均为1.5秒

测试输出 #

00 min, 00 sec,  579 ms : 填充数组集1
00 min, 37 sec,  875 ms : 写入数组至表格
00 min, 00 sec,  593 ms : 填充数组集2
00 min, 01 sec,  422 ms : 追加数组至表格
00 min, 00 sec,  578 ms : 填充数组集3
00 min, 01 sec,  531 ms : 追加数组至表格
00 min, 00 sec,  594 ms : 填充数组集4
00 min, 01 sec,  531 ms : 追加数组至表格

问题 #

1. 为何追加10000行至表格的速度比首次写入快25倍？
2. 如何加速首次将数组写入表格的操作？

解答 #

1. 性能差异的核心原因 #

差异来自Excel ListObject的行分配机制和初始化开销：

• 首次写入：表格初始仅1行空数据行，直接写入10000行数组时，Excel需要逐行创建新的ListRow对象，同时触发格式同步、公式依赖检查、内存初始化等后台操作，这些步骤的累加开销极大。
• 追加操作：AddArrayToTable先通过.Resize一次性扩展表格范围，直接分配好所需的内存和行对象，之后仅需将数组值写入已准备好的单元格区域，避免了逐行创建ListRow的高额开销。此外，首次写入后表格的结构、格式已完成初始化，后续追加无需重复处理这些步骤。

2. 加速首次写入的优化方案 #

参考追加操作的思路，先预分配表格行范围，再写入数组，同时关闭Excel后台干扰项。修改WriteArrayToTable过程如下：

Sub WriteArrayToTable()
'将数组"Data_Array"写入表格"Table_Name"
    Dim MyTable As ListObject
    Dim target As Range
    Dim totalRows As Long
 
    Set MyTable = Worksheets(Sheet_Name).ListObjects(Table_Name)  

    Call Init_Timer  

    '关闭Excel后台操作，减少性能损耗
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    With MyTable  
        totalRows = UBound(Data_Array, 1)
        '预先调整表格大小，一次性分配所有需要的行
        .Resize Range(Table_Name & "\[#All\]").Resize(totalRows + 1, Nr_of_Columns) ' +1为表头行
        Set target = .DataBodyRange.Cells(1, 1)
        target.Resize(UBound(Data_Array, 1), UBound(Data_Array, 2)).Value = Data_Array  
    End With  

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

    Call Show_Time("写入数组至表格")  
    Debug.Print  
End Sub

额外优化建议：

• 首次写入前，确保表格已通过Clear_Data_Resize调整为最小行，避免不必要的初始行干扰。
• 批量写入时，尽量减少Excel对象的频繁调用，始终以数组操作优先。

测试代码 #

运行代码需在Sheet1中创建名为Table1的34列表格：

模块声明 #

Option Explicit
Public Const Sheet_Name = "Sheet1"      '工作表名称
Public Const Table_Name = "Table1"      '数据表名称
Public Data_Array() As Variant          '二维数据数组
Public Const Nr_of_Columns = 34         '数据列数
Public Const Nr_of_Data_Rows = 10000    '数据行数
Public Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long
Public Calc_Time As Long                '计算开始时间

辅助过程 #

Sub Clear_Table()
    '清空表格内容并调整为1行
    Call Clear_Data_Resize(1)  
End Sub

Sub Clear_Data_Resize(H As Long)
'清空表格内容并调整为H行
    Dim tbl As ListObject, k As Long
    Set tbl = Sheets(Sheet_Name).ListObjects(Table_Name)  

    If Not (tbl.DataBodyRange Is Nothing) Then  
        With tbl  
            .DataBodyRange.ClearContents  
            If H = 1 Then  
                .Resize Range(Table_Name & "\[#All\]").Resize(2, 34)  
            Else  
                .Resize Range(Table_Name & "\[#All\]").Resize(H, 34)  
            End If                    
        End With  
    End If  
End Sub

Sub Fill_Array(n As String)
'向Data_Array(1到Nr_of_Data_Rows, 1到Nr_of_Columns)填充文本
'填充文本包含随机数，每个元素均不同
    Dim i As Long, j As Long
    
    Call Init_Timer  

    ReDim Data_Array(1 To Nr_of_Data_Rows, 1 To Nr_of_Columns)  

    For i = 1 To Nr_of_Data_Rows 
        For j = 1 To Nr_of_Columns    
            Data_Array(i, j) = n & ": " & Str(i) & " ... " & Str(j) & vbLf & _ 
                                Mid(Str(Rnd), 3, 3)  
        Next  
    Next  

    Call Show_Time(n)  

End Sub

Sub AddArrayToTable()
'将数组"Data_Array"追加至表格"Table_Name"末尾
    Dim MyTable As ListObject
    Dim target As Range
    Dim H1 As Long, H2 As Long, Rows_1 As Long, Rows_2 As Long

    Set MyTable = Worksheets(Sheet_Name).ListObjects(Table_Name)  

    H1 = LBound(Data_Array, 1)  
    H2 = UBound(Data_Array, 1)  

    Call Init_Timer  

    Application.ScreenUpdating = False  

    With MyTable  
        Rows_1 = .ListRows.Count  
        Rows_2 = H2 - H1 + 1  
        .Resize Range(Table_Name & "\[#All\]").Resize(Rows_1 + Rows_2, 34)    
        Set target = .HeaderRowRange.Cells(1, 1)    
        target.Offset(1 + Rows_1).Resize(UBound(Data_Array, 1), UBound(Data_Array, _
                 2)).Value = Data_Array  
    End With  

    Call Show_Time("追加数组至表格")  
    Debug.Print  

End Sub

Sub Init_Timer()
'初始化开始时间
    Calc_Time = GetTickCount
End Sub

Sub Show_Time(n As String)
'显示耗时
    Dim i As Long, m As Long, s As Long, ms As Long

    i = GetTickCount - Calc_Time  
    m = Fix(i / 60000)  
    s = Fix((i - m * 60000) / 1000)  
    ms = (i - m * 60000 - s * 1000)  

    Debug.Print Format(m, "00") & " min, " & Format(s, "00") & " sec,  " & _
        Format(ms, "000") & " ms : " & n  

End Sub

测试主过程 #

Sub test()

    '创建第1个10000×34的数组  
    Call Fill_Array("填充数组集1")  
    '将数组写入表格  
    Call WriteArrayToTable  
      
    '创建第2个10000×34的数组  
    Call Fill_Array("填充数组集2")  
    '将数组追加至表格末尾  
    Call AddArrayToTable  

    '创建第3个10000×34的数组  
    Call Fill_Array("填充数组集3")  
    '将数组追加至表格末尾  
    Call AddArrayToTable  

    '创建第4个10000×34的数组  
    Call Fill_Array("填充数组集4")  
    '将数组追加至表格末尾  
    Call AddArrayToTable  

End Sub

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