动态数组的下标超出范围错误VBA

Question

我正在尝试构建一个代码，该代码将循环遍历数组中的列，检查值是否唯一，然后计算给定字符串在数组中出现的次数。 每当我传递 UBound 或 LBound 命令时，我都会收到下标超出范围错误。我确信我犯了一个愚蠢的错误，因为我对编码和 VBA 还很陌生。

星号是对这篇文章的评论，而不是代码中的评论。

*有问题的代码片段

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 array is defined elsewhere                
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
           ' If yes, find its index and increment the occurrences
           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
           ' If no, add the value to uniqueValues and set occurrences to 1


           *code fails here trying to assign value k
           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

*code snippet that is having issue

*function that is called in the snippet
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

我尝试了不同的方法来构建阵列，但都没有解决问题。我认为这是 VBA 中数组工作原理的问题。

Answer 1

使用

Dictionary

对象是获取唯一列表和计数的更好方法

Dim cell As Variant, objDic as Object, sKey
Set objDic = CreateObject("scripting.dictionary")
For Each cell In partNumberRange
     partNumber = cell.value
     If objDic.exists(partNumber) Then
        objDic(partNumber) = objDic(partNumber) + 1
     Else
        objDic(partNumber) = 1
     End If
Next cell
' Check the unique list
For Each sKey in objDic.keys
    Debug.Print sKey, objDic(sKey) 
Next