error 1004 unable to get the unique property of the worksheetfunction class

Question

I have written a script to insert a range of cells into a list box of the userform in 3 steps:

1. The main table (A2:N...) gets filtered to a specific value in column A.

2. The values in column G get put into a range, then a sorted array with unique values.

3. The array is inputed in the listbox

I am getting the error 1004 regarding the "unique" function on rang1. I don't understand what is the issue.

Can someone kindly help me?

Private Sub UserForm_Initialize()

Dim rang, rang1,  As Range
Dim lstrow, x As Long
Dim ListUniq(), ListNoEmpty(), As Variant
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim lr As Integer

Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set rang = ws.Range("B3").CurrentRegion
lstrow = rang.Rows.Count + 1

'Step1.The main table (A2:N...) get's filtered to a specific (Dental) value on column A.
ws.Range("$A$2:$N$" & lstrow).AutoFilter _
        Field:=1, _
        Criteria1:="Dental", _
        Operator:=xlFilterValues
lr = Range("A" & Rows.Count).End(xlUp).Row


'Step2.The values in column G get put into a range, then a sorted array with unique values.
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)

ReDim ListUniq(WorksheetFunction.CountA(rang2))
ListUniq = WorksheetFunction.Unique(rang1)
ListUniq = WorksheetFunction.sort(ListUniq)

'Resize Array prior to loading data
ReDim ListNoEmpty(WorksheetFunction.CountA(ListUniq))
'Step3.The array is inputed in the listbox
'Loop through each cell in Range and store value in Array
x = 0

For Each cell In ListUniq
    If cell <> "" Then
        ListNoEmpty(x) = cell
        x = x + 1
    End If
Next cell

ProviderListBx.list = ListNoEmpty

End Sub

Answer 1

Unique Values to Listbox

• This will work for any version of Excel ie it doesn't use the Unique and Sort functions but it uses a dictionary and an ascending integer sequence in a helper column instead.

Option Explicit

Private Sub UserForm_Initialize()
    PopulateProviderListBox
End Sub

Sub PopulateProviderListBox()
    Const ProcName As String = "PopulateProviderListBox"
    On Error GoTo ClearError

    Application.ScreenUpdating = False

    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1") ' adjust!
    ' Clear filters.
    If ws.FilterMode Then ws.ShowAllData
    
    ' Reference the range ('rg').
    Dim fCell As Range: Set fCell = ws.Range("A2")
    Dim rg As Range
    With fCell.CurrentRegion
        Set rg = fCell.Resize(.Row + .Rows.Count - fCell.Row, _
            .Column + .Columns.Count - fCell.Column)
    End With
    
    ' Expand the range by one column and reference it ('nrg').
    Dim cCount As Long: cCount = rg.Columns.Count + 1
    Dim nrg As Range: Set nrg = rg.Resize(, cCount)
    
    ' Write an ascending integer sequence to the (new) helper column.
    Dim rCount As Long: rCount = rg.Rows.Count
    nrg.Columns(cCount).Value = ws.Evaluate("=ROW(1:" & rCount & ")")
    
    ' Sort the new range by the lookup column ('7').
    nrg.Sort nrg.Columns(7), xlAscending, , , , , , xlYes
    ' Reference the data (no headers) of the lookup column ('lrg').
    Dim lrg As Range: Set lrg = nrg.Columns(7).Resize(rCount - 1).Offset(1)
    
    ' Filter the new range by the criteria in the criteria column ('1').
    nrg.AutoFilter 1, "Dental"
        
    ' Attempt to reference all visible cells ('vrg') of the lookup column.
    Dim vrg As Range
    On Error Resume Next
        Set vrg = lrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' Turn off the autofilter.
    ws.AutoFilterMode = False
    
    If Not vrg Is Nothing Then
        ' Return the unique (sorted) values
        ' in the keys of a dictionary ('dict').
        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        dict.CompareMode = vbTextCompare
        Dim vCell As Range
        For Each vCell In vrg.Cells
            dict(vCell.Value) = Empty
        Next vCell
        ' Return the unique (sorted) values in the listbox.
        If dict.Count > 0 Then ProviderListBx.List = dict.Keys
    End If
    
    ' Sort the new range by the helper column to regain initial order.
    nrg.Sort nrg.Columns(cCount), xlAscending, , , , , , xlYes
    ' Clear the helper column.
    nrg.Columns(cCount).Clear

    Application.ScreenUpdating = True

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

Answer 2

Even if you Excel version accepts UNIQUE and Sort formulas and then WorksheetFunction methods, both of them do not behave exactly as Excel respective formulas...

WorksheetFunction.UNIQUE does not work on discontinuous ranges. The next line, returns such a range:

  Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)

Even ListUniq = WorksheetFunction.sort(rang1) does not work because of the above mentioned behavior. If ListUniq would be a continuous range it will work.

Then, declaring Dim ListUniq() makes useless the line ReDim ListUniq(WorksheetFunction.CountA(rang2)) , which anyhow uses an non existing range. Probably, it is a type and it should be rang1 , but still useless. VBA is able to return the array without needing a previous ReDim . Only the range to be continuous.

In such cases, a function transforming the discontinuous range in a continuous array would solve your issue:

Private Function ListUniqFromDiscR_2D(rng As Range) As Variant 'makes 2D (one column) array from a discontinuous range
    Dim A As Range, ListUniq, count As Long, i As Long
    
    ReDim ListUniq(1 To rng.cells.count, 1 To 1): count = 1
    For Each A In rng.Areas
            For i = 1 To A.cells.count
                ListUniq(count, 1) = A.cells(i).Value: count = count + 1
            Next
    Next
    ListUniqFromDiscR_2D = ListUniq
End Function

It can be used in your code as:

   Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
   ListUniq = ListUniqFromDiscR_2D(rang1)            'the continuous extracted array
    Debug.Print Join(Application.Transpose(ListUniq), "|") 'just to visually see the (continuous) returned array
    ListUniq = WorksheetFunction.unique(ListUniq)  'the unique elements array
    ListUniq = WorksheetFunction.Sort(ListUniq)    'the unique sorted array
     Debug.Print Join(Application.Transpose(ListUniq), "|") 'just to the unique, sorted array (in Immediate Window)...

But if your Excel version is not able to handle Unique and Sort , there are not standard VBA functions doing it very fast. If this is your case, I can also post such functions.