I have written a script to insert a range of cells into a list box of the userform in 3 steps:
The main table (A2:N...) gets filtered to a specific value in column A.
The values in column G get put into a range, then a sorted array with unique values.
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
CodePudding user response：
Unique Values to Listbox
- This will work for any version of Excel i.e. it doesn't use the
UniqueandSortfunctions 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
CodePudding user response：
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(rng) '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.