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
CodePudding user response：
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 theTestprocedure) 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
CodePudding user response：
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