VBA二维Variant数组赋值与分组求和问题：数组Resize失败

问题描述 #

我正在遍历一个二维Variant数组（输入格式为Variant/Variant(1 to N, 1 to 4)，行数可变、列数固定为4），需要筛选出属于Inventory类的行，并将这些行的剩余元素存入新数组，但始终无法正确调整新数组的大小。最终目标是生成一张分组求和表：第一列为原数组第三列的去重值，第二列为对应分组下Inventory类第四列的求和值，第三列为对应分组下Sold类第四列的求和值。

现有代码 #

Function sortingArray( arr As Variant )
   Dim counter As Integer
   Dim i As Long
   Dim j As Variant
   Dim z As Variant
   Dim inventory As Variant 
   'if I declare it as: Dim inventory(0,1) As Variant it does not compile
   Dim soldItems As Variant
   cntr = 0
   For i = LBound(arr) To UBound(arr)
      If InStr(arr(i,2), "Inventory") Then
         j = arr(i,3)
         z = arr(i,4)
         If counter = 0 Then
            inventory(0,0) = j
            inventory(0,1) = z
         Else
            ReDim Preserve inventory(counter + 1,1)
            inventory(counter + 1,0) = j
            inventory(counter + 1,1) = z
         End If
         counter = counter + 1
      End If
   Next i
   sortingArray = inventory
End Function

示例输入数组 #

目标结果表 #

解决方案 #

1. 数组调整失败的原因 #

VBA中ReDim Preserve仅允许调整数组的最后一维大小。你当前的数组是(行,列)结构，直接调整行维度会导致数据丢失，这是代码无法正确扩容的核心原因。

2. 推荐方案：用字典实现分组求和 #

使用Scripting.Dictionary可以自动完成分组去重与求和，无需手动处理数组扩容，代码更简洁高效：

Function GenerateSummary(arr As Variant) As Variant
    Dim dict As Object
    Dim i As Long
    Dim groupCode As String
    Dim isInventory As Boolean
    Dim sumVal As Double
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历输入数组，统计分组求和
    For i = LBound(arr, 1) To UBound(arr, 1)
        groupCode = arr(i, 3)
        isInventory = InStr(arr(i, 2), "Inventory") > 0
        sumVal = CDbl(arr(i, 4))
        
        ' 初始化新分组的求和项
        If Not dict.Exists(groupCode) Then
            dict(groupCode) = Array(0, 0) ' 索引0=Inventory求和，1=Sold求和
        End If
        
        ' 更新对应分组的求和值
        If isInventory Then
            dict(groupCode) = Array(CDbl(dict(groupCode)(0)) + sumVal, CDbl(dict(groupCode)(1)))
        Else
            dict(groupCode) = Array(CDbl(dict(groupCode)(0)), CDbl(dict(groupCode)(1)) + sumVal)
        End If
    Next i
    
    ' 将字典数据转换为结果数组
    Dim resultArr() As Variant
    Dim key As Variant
    Dim rowIndex As Long
    
    ReDim resultArr(1 To dict.Count + 1, 1 To 3)
    ' 写入表头
    resultArr(1, 1) = "group code"
    resultArr(1, 2) = "Inventory"
    resultArr(1, 3) = "Sold"
    
    ' 写入分组数据
    rowIndex = 2
    For Each key In dict.Keys
        resultArr(rowIndex, 1) = key
        resultArr(rowIndex, 2) = dict(key)(0)
        resultArr(rowIndex, 3) = dict(key)(1)
        rowIndex = rowIndex + 1
    Next key
    
    GenerateSummary = resultArr
End Function

3. 原数组方案的修复（若坚持用数组） #

如果必须使用数组处理，需先统计符合条件的行数，再初始化数组，或通过转置规避ReDim Preserve的限制：

Function sortingArray(arr As Variant) As Variant
    Dim counter As Long
    Dim i As Long
    Dim inventory() As Variant
    
    ' 先统计Inventory类的行数
    counter = 0
    For i = LBound(arr, 1) To UBound(arr, 1)
        If InStr(arr(i, 2), "Inventory") > 0 Then
            counter = counter + 1
        End If
    Next i
    
    ' 初始化并填充数组
    If counter > 0 Then
        ' 先创建(列,行)结构的数组，方便ReDim Preserve
        ReDim inventory(1 To 2, 1 To counter)
        counter = 0
        For i = LBound(arr, 1) To UBound(arr, 1)
            If InStr(arr(i, 2), "Inventory") > 0 Then
                counter = counter + 1
                inventory(1, counter) = arr(i, 3)
                inventory(2, counter) = arr(i, 4)
            End If
        Next i
        ' 转置为(行,列)结构返回
        sortingArray = Application.Transpose(inventory)
    Else
        sortingArray = Empty ' 无符合条件的行时返回空
    End If
End Function

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