Есть ли способ построить эффективную функцию vba, которая будет принимать диапазон в качестве аргумента и возвращать массив уникальных значений (освобожденных от дубликатов)?

Question

Я хотел бы создать функцию vba (Publi c Function), которая при заданном диапазоне в 1 столбец будет возвращать массив своих уникальных значений. Он должен выполнять ту же работу, что и метод RemoveDuplicates, но не изменяя ничего, он должен только возвращать массив уникальных значений.

Я написал этот код

Public varData() As Variant

Public Sub Suplem(rng As Range)

Dim tempSheet As Worksheet
Size = rng.Rows.Count
On Error GoTo tuda1
    Worksheets.Add.Name = "temp"
tuda1:
    Set tempSheet = ActiveWorkbook.Worksheets("temp")
With tempSheet
    tempSheet.Range(tempSheet.Cells(1, 1), tempSheet.Cells(Size, 1)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
    tempSheet.Range(tempSheet.Cells(1, 1), tempSheet.Cells(Size, 1)).RemoveDuplicates
    varData = tempSheet.Range(tempSheet.Cells(1, 1), tempSheet.Cells(Size, 1)).Value
End With
tempSheet.Delete

End Sub


Public Function UniqueVals(rng As Range)

ReDim varData(rng.Rows.Count - 1)
Call Suplem(rng)
Dim a() As Variant
UniqueVals = varData
Erase varData

End Function

Функция UniqueVals здесь вызывает Sub Suplem, который создает временный лист, вставляет в него копию исходного диапазона и удаляет из него дубликаты. Затем он записывает окончательный диапазон, освобожденный от дубликатов, в глобальный массив varData. После этого функция UniqueVals возвращает данные в varData и очищает их.

Проблема в том, что эта функция возвращает #VALUE! из-за временного листа, который создается и изменяется в Sub. Любые идеи о том, как избежать этой ошибки? Могу ли я использовать вместо этого массив, но в виде диапазона, то есть путем изменения его по формуле?

Answer 1

Если у человека нет формулы Dynami c Array UNIQUE(), используйте эту функцию, использующую словарь.

Public Function UniqueVals(rng As Range) As Variant
    Dim rngArray As Variant
    rngArray = Intersect(rng, rng.Parent.UsedRange).Value

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim t As Variant
    For Each t In rngArray
        On Error Resume Next
            dict.Add t, t
        On Error GoTo 0
    Next t

    Dim temp() As Variant
    ReDim temp(1 To dict.Count, 1 To 1)

    Dim x As Long
    x = 1
    Dim key As Variant
    For Each key In dict.Keys
        temp(x, 1) = key
        x = x + 1
    Next key

    UniqueVals = temp
End Function