VBA中创建未知大小二维数组的优化方案咨询（救助猫场景）

问题背景 #

处理救助猫信息数据时，需基于已有的AllVetting二维主数据数组，实现以下逻辑：

• 筛选出AlteredYN字段值为UnAltered（未绝育）的猫
• 将筛选结果存入新数组Unaltered
• 对新数组排序后写入指定工作表

现有代码可正常运行，但存在缺陷：因无法提前预知筛选后的数据量，初始将Unaltered数组设为与AllVetting同等大小，且二维数组无法直接通过ReDim Preserve调整行数，导致排序操作需手动指定实际有效行数，逻辑不够严谨。

优化方案：先统计再初始化数组 #

核心思路是先遍历主数组统计符合条件的记录数，再基于该数量精准初始化目标数组，避免数组空间浪费，同时让后续排序、写入操作直接使用数组的上下界，逻辑更严谨。

优化后完整代码 #

Option Explicit

Public Enum eColumns
    Col_AllVetting_IntakeDate = 1
    Col_AllVetting_AnimalID = 2
    Col_AllVetting_AnimalIDx = 3
    Col_AllVetting_Name = 4
    Col_AllVetting_NameNChip = 5
    Col_AllVetting_Description = 6
    Col_AllVetting_Sex = 7
    Col_AllVetting_Age = 8
    Col_AllVetting_DOB = 9
    Col_AllVetting_Microchip = 10
    Col_AllVetting_AlteredYN = 11
    Col_AllVetting_Location = 12
    Col_AllVetting_Status = 13
    Col_AllVetting_Attributes = 14
    Col_AllVetting_Weight = 15
    Col_AllVetting_Price = 16
    Col_AllVetting_FosterName = 17
    Col_AllVetting_FosterPhone = 18
    Col_AllVetting_PhotoYN = 19
    Col_AllVetting_BioYN = 20
End Enum

Sub Unaltered(ByRef AllVetting)
    Dim i As Long
    Dim rowCount As Long
    Dim columnCount As Long
    columnCount = 7
    
    ' 第一步：统计符合条件的记录数
    For i = LBound(AllVetting, 1) To UBound(AllVetting, 1)
        If AllVetting(i, Col_AllVetting_AlteredYN) = "UnAltered" Then
            rowCount = rowCount + 1
        End If
    Next i
    
    ' 第二步：精准初始化目标数组
    Dim Unaltered() As Variant
    If rowCount > 0 Then
        ReDim Unaltered(1 To rowCount, 1 To columnCount)
        
        ' 第三步：遍历主数组，写入符合条件的数据
        Dim targetRow As Long
        targetRow = 1
        For i = LBound(AllVetting, 1) To UBound(AllVetting, 1)
            If AllVetting(i, Col_AllVetting_AlteredYN) = "UnAltered" Then
                Unaltered(targetRow, 1) = AllVetting(i, Col_AllVetting_NameNChip)
                Unaltered(targetRow, 2) = AllVetting(i, Col_AllVetting_Location)
                Unaltered(targetRow, 3) = AllVetting(i, Col_AllVetting_FosterPhone)
                Unaltered(targetRow, 4) = AllVetting(i, Col_AllVetting_Sex)
                Unaltered(targetRow, 5) = AllVetting(i, Col_AllVetting_Weight)
                Unaltered(targetRow, 6) = AllVetting(i, Col_AllVetting_DOB)
                Unaltered(targetRow, 7) = AllVetting(i, Col_AllVetting_Status)
                targetRow = targetRow + 1
            End If
        Next i
        
        ' 排序：直接使用数组上下界，无需手动指定行数
        Dim sortString As String
        sortString = "2,A,6,D,1,A"
        Call QuickSort2D(Unaltered, sortString, LBound(Unaltered), UBound(Unaltered))
        
        ' 写入工作表
        Worksheets("Unaltered").Range("A1").Resize(rowCount, columnCount).Value = Unaltered
    Else
        ' 无符合数据时清空目标工作表
        Worksheets("Unaltered").UsedRange.ClearContents
    End If
    
    MsgBox "Unaltered 子过程执行完成"
End Sub

改进点说明 #

• 精准数组初始化：通过两次遍历（先统计、再赋值），让Unaltered数组的行数完全匹配筛选结果数量，避免内存浪费
• 严谨排序逻辑：排序时直接使用数组的LBound和UBound，无需依赖额外变量，降低出错风险
• 边界处理：新增无符合条件数据时的清空逻辑，避免残留旧数据
• 可读性提升：新增targetRow变量明确标记目标数组写入位置，逻辑更清晰

备选方案：一维数组转二维（单次遍历） #

如果不想进行两次遍历，可以先将符合条件的行数据存入一维数组（每个元素是一行数据的子数组），最后转成二维数组：

Sub Unaltered_Alternative(ByRef AllVetting)
    Dim i As Long, j As Long
    Dim columnCount As Long
    columnCount = 7
    
    Dim tempArr() As Variant
    ReDim tempArr(0 To 0) ' 初始化临时一维数组
    
    For i = LBound(AllVetting, 1) To UBound(AllVetting, 1)
        If AllVetting(i, Col_AllVetting_AlteredYN) = "UnAltered" Then
            ReDim Preserve tempArr(0 To UBound(tempArr) + 1)
            tempArr(UBound(tempArr)) = Array( _
                AllVetting(i, Col_AllVetting_NameNChip), _
                AllVetting(i, Col_AllVetting_Location), _
                AllVetting(i, Col_AllVetting_FosterPhone), _
                AllVetting(i, Col_AllVetting_Sex), _
                AllVetting(i, Col_AllVetting_Weight), _
                AllVetting(i, Col_AllVetting_DOB), _
                AllVetting(i, Col_AllVetting_Status) _
            )
        End If
    Next i
    
    Dim Unaltered() As Variant
    Dim rowCount As Long
    rowCount = UBound(tempArr)
    If rowCount > 0 Then
        ' 将一维数组转成二维数组
        ReDim Unaltered(1 To rowCount, 1 To columnCount)
        For i = 1 To rowCount
            For j = 1 To columnCount
                Unaltered(i, j) = tempArr(i)(j - 1)
            Next j
        Next i
        
        ' 排序与写入逻辑同主方案
        Dim sortString As String
        sortString = "2,A,6,D,1,A"
        Call QuickSort2D(Unaltered, sortString, LBound(Unaltered), UBound(Unaltered))
        
        Worksheets("Unaltered").Range("A1").Resize(rowCount, columnCount).Value = Unaltered
    Else
        Worksheets("Unaltered").UsedRange.ClearContents
    End If
    
    MsgBox "Unaltered 子过程执行完成"
End Sub

该方案只需一次遍历主数组，但转置数组会增加少量逻辑复杂度，适合数据量较大的场景。

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