I would like to make a user-defined function union in VBA, such that:

1. it could take variable parameters
2. each parameter is a one-column range like A1, A2:A10; we don't need to consider passing constant values to parameters
3. we could consider, within one input range, there are no duplicates; but it is very possible to have duplicates among input ranges.
4. union combines the input ranges, and keeps the order of the elements. For instance, =union(A1:A5, C1:C2, E1:E3) has the following expected output in Column I:

I wrote the following code which works. However, the problem is that it is slow. A union over a list of 4000 rows and a list of 20 rows takes already several seconds. First, I don't know the way I coded arrays could be improved. Second, the algorithm just consists in comparing each new element against the accumulating result list; there is no sort, no other techniques. Third, I don't know if there are any existing functions we could use in other objects of VBA (eg, VBA FILTER function, Collection, ArrayLists, Scripting.Dictionary).

Could anyone propose a more efficient code?

Function getDimension(var As Variant) As Long
    On Error GoTo Err
    Dim i As Long
    Dim tmp As Long
    i = 0
    Do While True
        i = i   1
        tmp = UBound(var, i)
    Loop
Err:
    getDimension = i - 1
End Function

Function exists(v As Variant, arr As Variant, resCount As Long) As Boolean
    If resCount = 0 Then
        exists = False
    Else
        exists = False
        i = LBound(arr, 1)
        Do While (i <= resCount) And (Not exists)
            If arr(i) = v Then
                exists = True
            End If
            i = i   1
        Loop
    End If
End Function

' assumption: every input is a range (eg, A1, A1:A2)
' assumption: each input range has only one column
Function union(ParamArray arr() As Variant) As Variant
    Dim res As Variant
    ReDim res(1 To 100000)
    Dim resCount As Long
    resCount = 0
    
    For k = LBound(arr) To UBound(arr)
        Dim arrk As Variant
        Dim v
        arrk = arr(k).Value2
        If getDimension(arrk) = 0 Then 'case of A1, B1
            v = arrk
            If Not exists(v, res, resCount) Then
                resCount = resCount   1
                res(resCount) = v
            End If
        ElseIf getDimension(arrk) = 2 Then 'case of A1:A10, B1:B10
            For i = LBound(arrk, 1) To UBound(arrk, 1)
                v = arrk(i, 1)
                If Not exists(v, res, resCount) Then
                    resCount = resCount   1
                    res(resCount) = v
                End If
            Next i
        End If
    Next k
    
    ReDim Preserve res(1 To resCount)
    union = Application.WorksheetFunction.Transpose(res)
End Function

CodePudding user response：

Something like this should work, using a Dictionary to eliminate duplicates.

Function UniqueValues(ParamArray arr() As Variant)
    Dim r, c As Range, v, dict
    Set dict = CreateObject("scripting.dictionary")
    For Each r In arr
        For Each c In r.Cells
            v = c.Value
            If Len(v) > 0 Then dict(v) = 1
        Next c
    Next r
    UniqueValues = ToColumn(dict.keys)
End Function

Function ToColumn(arr)
    Dim arrOut, i As Long
    ReDim arrOut(1 To UBound(arr)   1, 1 To 1)
    For i = 1 To UBound(arr)   1
        arrOut(i, 1) = arr(i - 1)
    Next i
    ToColumn= arrOut
End Function