VBA TIPS
Getting unique records from 2D (1D) array

Here is a sample function for getting unique records from 1D(2D) array with Collection Object.

Remarks

This function would create a loop that goes through un-unique array and add each value to the Collection object by Add Method.

When the values being added by Add Method, an error also occurs if a specified key duplicates the key for an existing member of the collection. So avoiding the error by error trap, so that remains the unique records only.

Example

Place un-unique values in the range A1 to A10 as follows, then run the procedure named TestingFunction.

  • Column B is the result of this function. An argument is 2D array : [A1:A10].Value
  • Column C is the result of this function. An argument is 1D array : Array(1, 2, 3, 1, 2, 3, 1, 2, 3))
  • Column D is the result of this function. An argument is 2D array : [E1:E10].Value , but please note, it is an Empty


In case the argument is Empty, this function returns Null. So nothing returns into column D.

Because the worksheet value is recognised as 2D array, you need to exchange 1D array to 2Darray when an array is placed in the worksheet. Here I am using Application.Transpose function.



Place the following in the standard module.

Option Explicit

Sub TestingFunction()
    Dim buf As Variant

    'Getting an unique collection from the values in Worksheet(2D array)
    buf = Array_Unique_Collection([A1:A10].Value)

    'See result
    If Not IsNull(buf) Then
        [B1].Resize(UBound(buf)).Value = Application.Transpose(buf)
    End If

    'Getting an unique collection from the 1D array
    buf = Array_Unique_Collection(Array(1, 2, 3, 1, 2, 3, 1, 2, 3))

    'See result
    If Not IsNull(buf) Then
        [C1].Resize(UBound(buf)).Value = Application.Transpose(buf)
    End If

    'If empty range as specified as an argument, this UDF returns NULL
    buf = Array_Unique_Collection([E1:E10].Value)

    'See result
    If Not IsNull(buf) Then
        [D1].Resize(UBound(buf)).Value = Application.Transpose(buf)
    End If

End Sub

Function Array_Unique_Collection(ByVal NotUniqueArry As VariantAs Variant
'returns unique collection as a 1D array
'returns NULL when there is no value
    Dim cTmp As New Collection
    Dim i As Long
    Dim aTmp As Variant
    Dim vElm As Variant

    On Error Resume Next
    For Each vElm In NotUniqueArry
        cTmp.Add CStr(vElm)CStr(vElm)
    Next
    On Error GoTo 0

    If cTmp.Count = 1 And cTmp.Item(1) = vbNullString Then
        Array_Unique_Collection = Null
        Exit Function
    End If

    ReDim aTmp(1 To cTmp.Count)
    For i = 1 To cTmp.Count
        aTmp(i) = cTmp.Item(i)
    Next
    Array_Unique_Collection = aTmp
End Function

| HOME |
Copyright © cellmasters.net - colo's junk room All Right Reserved
ABOUT
WORKS
THE CELL MASTERS
CONTACT
LINKS
Tips and Information about Microsoft Excel|Masaru Kaji aka Colo