如何在VBA中将记录存入数组而非逐行写入Excel工作表？

原有功能说明 #

• 为Production、Development数据集分别创建字典Production_Dictionary、Development_Dictionary
• 遍历已存入数组Production_Array的生产数据
• 通过拼接三个ID字段生成的Production Item键，检查开发数据集是否包含对应记录
• 无匹配记录时，将该行写入Delete_Sheet
• 有匹配记录时，对比所有字段；若存在字段变更，将该行写入Change_Sheet并高亮变更字段

原运行缓慢的代码 #

For i = 1 To UBound(Production_Array, 1) '1 indicates upper-bound of rows
    Production_Item = Production_Array(i, ProductionID_1) & Production_Array(i, ProductionID_2) & Production_Array(i, ProductionID_3)
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Find Deleted Records
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Not Development_Dictionary.exists(Production_Item) Then 'If Production Item not found in Development
        Delete_Row = Delete_Sheet.Range("A1").CurrentRegion.Rows.Count + 1
        Set Delete_Record = Delete_Sheet.Range(Delete_Sheet.Cells(Delete_Row, 1), Delete_Sheet.Cells(Delete_Row, Last_Column_Development))
        Delete_Record = Application.Index(Production_Array, i)
        GoTo LineNext
    End If
    
    ItemRow = Development_Dictionary(Production_Item)
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Find Changed Records
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For x = 1 To Last_Column_Production 'Checking all fields for changes - Only for records found in each data set
        If Production_Array(i, x) <> Development_Array(ItemRow, x) Then

            If Not Pasted_Record Then
                Change_Row = Change_Sheet.Range("A1").CurrentRegion.Rows.Count + 1
                Set Change_Record = Change_Sheet.Range(Change_Sheet.Cells(Change_Row, 1), Change_Sheet.Cells(Change_Row, Last_Column_Production))
                Change_Record = Application.Index(Production_Array, i) 'Production_Record.Value
                Pasted_Record = True
            End If

            Change_Sheet.Cells(Change_Row, x).Interior.Color = vbRed
        End If
    Next x

Pasted_Record = False
LineNext:
Next i

问题痛点 #

原代码频繁读写Excel工作表（每找到一条删除/变更记录就立即写入），导致运行效率低下。尝试改用数组暂存结果后批量写入，但遇到以下问题：

• Application.Index可提取单行数据，但无法直接将该行添加到未知大小的动态数组
• 尝试ReDim Preserve未解决动态扩展数组的问题，基于Application.Index的转置方法难以理解

优化解决方案 #

核心思路：全程用数组暂存所有删除/变更记录及变更字段位置，遍历完成后一次性写入工作表，彻底减少工作表交互次数。

优化后代码 #

Sub OptimizedRecordComparison()
    Dim Delete_Records As Variant, Change_Records As Variant
    Dim Change_Highlights As Variant ' 存储需要高亮的(行索引,列索引)
    Dim delCount As Long, changeCount As Long, highlightCount As Long
    Dim i As Long, x As Long, xCol As Long, ItemRow As Long
    Dim Production_Item As String
    Dim hasChanges As Boolean
    
    ' 初始化动态数组（初始容量设为1，后续按需扩展）
    delCount = 0
    ReDim Delete_Records(1 To 1, 1 To Last_Column_Production)
    
    changeCount = 0
    ReDim Change_Records(1 To 1, 1 To Last_Column_Production)
    
    highlightCount = 0
    ReDim Change_Highlights(1 To 1, 1 To 2) ' 第一列存变更记录在数组中的行号，第二列存列号
    
    ' 遍历生产数据集数组
    For i = 1 To UBound(Production_Array, 1)
        Production_Item = Production_Array(i, ProductionID_1) & Production_Array(i, ProductionID_2) & Production_Array(i, ProductionID_3)
        
        ' 处理删除记录：开发数据集无匹配
        If Not Development_Dictionary.exists(Production_Item) Then
            delCount = delCount + 1
            ' 扩展删除记录数组容量
            ReDim Preserve Delete_Records(1 To delCount, 1 To Last_Column_Production)
            ' 将当前行数据复制到删除数组
            For x = 1 To Last_Column_Production
                Delete_Records(delCount, x) = Production_Array(i, x)
            Next x
            GoTo LineNext
        End If
        
        ItemRow = Development_Dictionary(Production_Item)
        hasChanges = False
        
        ' 处理变更记录：对比所有字段
        For x = 1 To Last_Column_Production
            If Production_Array(i, x) <> Development_Array(ItemRow, x) Then
                ' 首次发现变更，先把当前行加入变更数组
                If Not hasChanges Then
                    changeCount = changeCount + 1
                    ReDim Preserve Change_Records(1 To changeCount, 1 To Last_Column_Production)
                    ' 复制整行数据
                    For xCol = 1 To Last_Column_Production
                        Change_Records(changeCount, xCol) = Production_Array(i, xCol)
                    Next xCol
                    hasChanges = True
                End If
                
                ' 记录需要高亮的位置
                highlightCount = highlightCount + 1
                ReDim Preserve Change_Highlights(1 To highlightCount, 1 To 2)
                Change_Highlights(highlightCount, 1) = changeCount
                Change_Highlights(highlightCount, 2) = x
            End If
        Next x
        
LineNext:
    Next i
    
    ' --------------------------
    ' 批量写入删除记录到Delete_Sheet
    ' --------------------------
    If delCount > 0 Then
        With Delete_Sheet
            Dim delStartRow As Long
            delStartRow = .Range("A1").CurrentRegion.Rows.Count + 1
            .Range(.Cells(delStartRow, 1), .Cells(delStartRow + delCount - 1, Last_Column_Production)).Value = Delete_Records
        End With
    End If
    
    ' --------------------------
    ' 批量写入变更记录到Change_Sheet并高亮
    ' --------------------------
    If changeCount > 0 Then
        With Change_Sheet
            Dim changeStartRow As Long
            changeStartRow = .Range("A1").CurrentRegion.Rows.Count + 1
            ' 写入变更记录
            .Range(.Cells(changeStartRow, 1), .Cells(changeStartRow + changeCount - 1, Last_Column_Production)).Value = Change_Records
            
            ' 批量高亮变更字段
            Dim h As Long
            For h = 1 To highlightCount
                .Cells(changeStartRow + Change_Highlights(h, 1) - 1, Change_Highlights(h, 2)).Interior.Color = vbRed
            Next h
        End With
    End If
End Sub

关键优化点说明 #

1. 动态数组扩展：

   • 用计数器（delCount/changeCount）跟踪数组当前行数，每次新增记录时用ReDim Preserve扩展数组行数（仅修改最后一维，符合ReDim Preserve的限制）
   • 放弃Application.Index，改用循环复制数组元素，逻辑更直观易维护

2. 减少工作表交互：

   • 遍历过程中仅操作内存数组，完全避免频繁读写工作表
   • 遍历结束后通过一次Range.Value = 数组批量写入数据，效率提升显著

3. 变更高亮处理：

   • 用Change_Highlights数组暂存所有需要高亮的位置（变更记录在数组中的行号+列号）
   • 写入数据后再批量设置单元格颜色，避免逐行操作工作表

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