动态数组Subscript out of range错误排查求助

尝试遍历Excel列，检查值的唯一性并统计指定字符串出现次数，但调用UBound或LBound时始终报错：

subscript out of range

问题代码片段 #

主逻辑代码

Dim uniqueValues() As Variant
Dim occurrences() As Variant
Dim partNumber As String
Dim partNumberRange As Range
                
Erase uniqueValues
Erase occurrences
                
Dim tempVar1 As String
Dim tempVar2 As String
Dim j As Long
Dim k As Long

'fastenerSheets 数组已在其他位置定义                
Set partNumberRange = fastenerSheets(i - 1).Range("A2", "A" & CStr(diameterTestCount(i - 1) + 1))
Debug.Print partNumberRange.Address
                
Dim cell As Variant
For Each cell In partNumberRange
    partNumber = cell.value
    Debug.Print partNumber
    If IsInArray(partNumber, uniqueValues) Then
        ' 若已存在，找到索引并增加计数
        For j = LBound(uniqueValues) To UBound(uniqueValues)
            If uniqueValues(j) = partNumber Then
                Debug.Print uniqueValues(j)
                occurrences(j) = occurrences(j) + 1
                Exit For
            End If
        Next j
    Else
        ' 若不存在，添加到uniqueValues并将计数设为1
        ' 此处调用UBound时触发错误
        k = UBound(uniqueValues) + 1
        ReDim Preserve uniqueValues(1 To k)
        ReDim Preserve occurrences(1 To k)
        uniqueValues(k) = partNumber
        occurrences(k) = 1
    End If
Next cell

调用的IsInArray函数

Function IsInArray(val As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error Resume Next
    IsInArray = (UBound(Filter(arr, val)) > -1)
    On Error GoTo 0
End Function

错误原因 #

1. 空数组的边界调用问题：Erase执行后，uniqueValues和occurrences变成未初始化的空数组，直接调用UBound或LBound会触发下标越界——空数组没有有效的上下界。
2. Filter函数的局限性：IsInArray中的Filter无法处理空数组，虽然错误捕获跳过了报错，但第一次检查时数组为空，函数返回False后，后续执行UBound(uniqueValues)仍会触发错误。

修复方案 #

方案1：修正数组初始化与边界判断

修改数组初始化逻辑，处理空数组的特殊情况：

Dim uniqueValues() As Variant
Dim occurrences() As Variant
Dim partNumber As String
Dim partNumberRange As Range
                
' 初始化数组为含一个空元素的结构，避免空数组调用UBound报错
ReDim uniqueValues(1 To 1)
ReDim occurrences(1 To 1)
uniqueValues(1) = ""
occurrences(1) = 0
                
Dim tempVar1 As String
Dim tempVar2 As String
Dim j As Long
Dim k As Long

Set partNumberRange = fastenerSheets(i - 1).Range("A2", "A" & CStr(diameterTestCount(i - 1) + 1))
Debug.Print partNumberRange.Address
                
Dim cell As Variant
For Each cell In partNumberRange
    partNumber = cell.value
    Debug.Print partNumber
    ' 处理数组初始状态（仅含空元素）
    If uniqueValues(1) = "" Then
        uniqueValues(1) = partNumber
        occurrences(1) = 1
    ElseIf IsInArray(partNumber, uniqueValues) Then
        ' 已存在则更新计数
        For j = LBound(uniqueValues) To UBound(uniqueValues)
            If uniqueValues(j) = partNumber Then
                Debug.Print uniqueValues(j)
                occurrences(j) = occurrences(j) + 1
                Exit For
            End If
        Next j
    Else
        ' 不存在则扩容数组
        k = UBound(uniqueValues) + 1
        ReDim Preserve uniqueValues(1 To k)
        ReDim Preserve occurrences(1 To k)
        uniqueValues(k) = partNumber
        occurrences(k) = 1
    End If
Next cell

' 修复IsInArray函数，增加空数组判断
Function IsInArray(val As Variant, arr As Variant) As Boolean
    Dim arrBound As Long
    ' 先判断数组是否未初始化
    On Error Resume Next
    arrBound = UBound(arr)
    If Err.Number <> 0 Then
        IsInArray = False
        Exit Function
    End If
    On Error GoTo 0
    
    ' 处理数组仅含初始空元素的情况
    If arr(LBound(arr)) = "" And UBound(arr) = LBound(arr) Then
        IsInArray = False
        Exit Function
    End If
    
    IsInArray = (UBound(Filter(arr, val)) > -1)
End Function

方案2：改用Dictionary（更高效简洁）

用VBA的Dictionary对象自动处理唯一值，彻底避免数组边界问题：

Dim partCounts As Object
Set partCounts = CreateObject("Scripting.Dictionary")

Dim partNumber As String
Dim partNumberRange As Range
Set partNumberRange = fastenerSheets(i - 1).Range("A2", "A" & CStr(diameterTestCount(i - 1) + 1))

Dim cell As Variant
For Each cell In partNumberRange
    partNumber = cell.Value
    If partCounts.Exists(partNumber) Then
        partCounts(partNumber) = partCounts(partNumber) + 1
    Else
        partCounts(partNumber) = 1
    End If
Next cell

' 输出统计结果示例
Dim key As Variant
For Each key In partCounts.Keys
    Debug.Print key & ": " & partCounts(key)
Next key

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