excel - 数组操作期间下标超出范围

Question

我编写了以下函数，旨在获取输入数组，删除重复项并返回唯一值的数组。我查看了其他类似的开源函数，但也无法让它们工作。观察输入数组和函数数组 Arr 和 ArrCopy，它们的每个索引都有正确的数字和值。知道为什么我会收到超出范围的错误吗？

Public Function getUnique(Arr As Variant) As Variant
Dim ArrCopy As Variant
Dim i As Variant
Dim j As Variant
Dim counter As Integer

'copies input array, loops through copy and clears dupates
ArrCopy = Arr
   For i = LBound(Arr) To UBound(Arr)
        For j = LBound(ArrCopy) To UBound(ArrCopy)
           If Arr(i) = ArrCopy(j) And i <> j Then
               ArrCopy(j).Clear
           End If
         Next j
     Next i

'clears array, loops through copy and puts nonzero values back in Arr
Arr.Clear
counter = 0
For i = LBound(ArrCopy) To UBound(ArrCopy)
    If ArrCopy(i) <> "" Then
       ReDim Preserve Arr(0 To counter)
       Arr(counter) = ArrCopy(i)
       counter = counter + 1
    End If
Next i

'returns unique values
getUnique = Arr

End Function

更新:这就是数组的加载方式。从 FaneDuru 的评论中，我在观察表中看到输入数组实际上是二维的，所以这就是为什么我收到超出范围的错误......

'removes blanks from AO
wks.AutoFilterMode = False
wks.Range("A1:BO" & lastrow).AutoFilter Field:=41, Criteria1:="<>", Operator:=xlFilterValues

Set rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)

'loads SNs into array
Erase serialNum
serialNum = rng.Value

更新2:

这让我更亲近了。使用 2d 方法这会将所有重复设置为 0。然后我调用我找到的删除元素 sub ( Deleting Elements in an Array if Element is a Certain value VBA )。我正在修改原始文件以使用二维数组。我在 DeleteElementAt() 子项中的 Redim Preserve 行上收到下标超出范围错误。

Public Function GetUnique(Arr As Variant) As Variant

Dim i As Variant
Dim j As Variant
Dim counter As Integer

   For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr) To UBound(Arr)
           If i <> j And Arr(i, 1) = Arr(j, 1) Then
               Arr(j, 1) = "0"
           End If
         Next j
     Next i
     
counter = 0
For i = LBound(Arr) To UBound(Arr)
    If Arr(i, 1) = "0" Then
       Call DeleteElementAt(i, Arr)
       ReDim Preserve Arr(0 To UBound(Arr))
    End If
Next i

GetUnique = Arr

End Function

Public Sub DeleteElementAt(ByVal index As Integer, ByRef Arr As Variant)
       Dim i As Integer

        ' Move all element back one position
        For i = index + 1 To UBound(Arr)
            Arr(index, 1) = Arr(i, 1)
        Next i

        ' Shrink the array by one, removing the last one
'ERROR HERE
        ReDim Preserve Arr(LBound(Arr) To UBound(Arr) - 1, 1)
End Sub

Answer 1

返回数组中某个范围的唯一值

Option Explicit


Sub Test()
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim rg As Range: Set rg = ws.Range("A2:J21")
    Dim Data As Variant: Data = GetRange(rg)
    Dim Arr As Variant: Arr = ArrUniqueData(Data)
    
    ' Continue using 'Arr', e.g.:
    If Not IsEmpty(Arr) Then
        Debug.Print Join(Arr, vbLf)
    Else
        Debug.Print "Nope."
    End If
    
'    Dim n As Long
'    For n = 0 To UBound(Arr)
'        Debug.Print Arr(n)
'    Next n
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from a 2D array
'               to a 1D zero-based array, excluding error values and blanks.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueData( _
    Data As Variant, _
    Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare) _
As Variant
    Const ProcName As String = "ArrUniqueDatae"
    On Error GoTo ClearError
    
    Dim cLower As Long: cLower = LBound(Data, 2)
    Dim cUpper As Long: cUpper = UBound(Data, 2)
    Dim Key As Variant
    Dim r As Long
    Dim C As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = CompareMethod
        For r = LBound(Data, 1) To UBound(Data, 1)
            For C = cLower To cUpper
                Key = Data(r, C)
                If Not IsError(Key) Then ' exclude error values
                    If Len(Key) > 0 Then ' exclude blanks
                        .Item(Key) = Empty
                    End If
                End If
            Next C
        Next r
        If .Count = 0 Then Exit Function
        ArrUniqueData = .Keys
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

编辑

• 这将使用 (SpecialCells) 过滤的一列范围继续您的子项。您仍然需要之前的过程(Test 过程除外)，并且下面有一个新功能。

' This is your procedure!

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      ...
' Calls:        GetFilteredColumn
'                   GetRange
'               ArrUniqueData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub YourProcedure()
 
    ' ... whatever

    Set Rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)
    
    'Erase serialNum ' you don't need to erase
    serialNum = GetFilteredColumn(Rng)
    
    Dim Arr As Variant: Arr = ArrUniqueData(serialNum)
    
    ' Continue using 'Arr', e.g.:
    If Not IsEmpty(Arr) Then
        Debug.Print Join(Arr, vbLf)
    Else
        Debug.Print "Nope."
    End If

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the filtered values of a column range
'               in a 2D one-based array.
' Calls:        GetRange.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredColumn( _
    ByVal FilteredColumnRange As Range) _
As Variant
    Const ProcName As String = "GetFilteredColumn"
    On Error GoTo ClearError

    With FilteredColumnRange
        
        Dim aCount As Long: aCount = .Areas.Count
        Dim aData As Variant: ReDim aData(1 To aCount)
        
        Dim arg As Range
        Dim a As Long
        
        For Each arg In .Areas
            a = a + 1
            aData(a) = GetRange(arg)
        Next arg
        
        Dim dData As Variant: ReDim dData(1 To .Cells.Count, 1 To 1)
        Dim sr As Long
        Dim dr As Long
        
        For a = 1 To aCount
            For sr = 1 To UBound(aData(a), 1)
                dr = dr + 1
                dData(dr, 1) = aData(a)(sr, 1)
            Next sr
        Next a
        
        GetFilteredColumn = dData

    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function