Subscript out of range during array manipulation

user_12285522 0
Viewed 130

I've written the below function intended to take an input array, delete the duplicates and return an array of unique values. I've looked at other functions open source that are similar but could not get them to work either. Watching both input array and the function arrays, Arr and ArrCopy, they have the correct number and value for each index. Any ideas why I'm getting an out of range error?

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

Update: This is how the array gets loaded. From FaneDuru's comment, I see in the watch table that the input array is actually 2D, so that's why I'm getting an out of range error....

'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

Update 2:

This has me a lot closer. Using the 2d approach This will set all of the repeats to 0. Then I call a delete element sub I found (Deleting Elements in an Array if Element is a Certain value VBA). I am modifying the original to work with 2D array. I am getting a subscript out of range error on my Redim Preserve line within the DeleteElementAt() sub.

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
vba excel
2 Answers

Return the Unique Values From a Range in an Array

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

EDIT

  • This will continue your sub using the (SpecialCells) filtered one-column range. You still need the previous procedures (except the Test procedure) and there is a new function below.
' 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
user_98140690

When you assign the values of an Excel range to a variant in VBA you always get a 2D array even if your range is a single column or row i.e. you get an array that is dimensioned as (1 to X,1 to 1). To get an array with dimensions (1 to X) you need to encapsulate the 'get values' code in a worksheetFunction.Transpose() call.

Assuming you have got your array into a 1D form you can then use either an ArrayList or Scripting.Dictionary to simplify compiling unique values. No need to get messyt with array indeces at all.

This is the ArrayList Version

Public Function getUnique(Arr As Variant) As Variant

    Dim myList As Object
    Set myList = CreateObject("System.collections.Arraylist")
    
    Dim myItem As Variant
    For Each myItem In Arr
    
        If myItem <> 0 Then
    
            If Not myList.Contains(myItem) Then
            
                myList.Add myItem
                
            End If
            
        End If
            
    Next
    
    getUnique = myList.toarray

End Function

This is the Scripting.Dictionary version

Public Function getUnique(Arr As Variant) As Variant

    Dim myList As Object
    Set myList = CreateObject("Scripting.Dictionary")
    
    Dim myItem As Variant
    For Each myItem In Arr
    
        If myItem <> 0 Then
    
            If Not myList.exists(myItem) Then
            
                myList.Add myList.Count, myItem
                
            End If
            
        End If
            
    Next
    
    getUnique = myList.Items

End Function
user_71773460
Related