error 1004 无法获取工作表函数类的唯一属性

Question

我编写了一个脚本，通过 3 个步骤将一系列单元格插入到用户窗体的列表框中：

1. 主表 (A2:N...) 被过滤为 A 列中的特定值。

2. G 列中的值被放入一个范围，然后是一个具有唯一值的排序数组。

3. 列表框输入数组

   我收到有关 rang1 上“唯一”功能的错误 1004。我不明白这是什么问题。

   有人可以帮助我吗？

   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

列表框的唯一值

• 这适用于任何版本的 Excel，即它不使用 Unique 和 Sort 函数，而是在辅助列中使用字典和升序整数序列。

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!
    ' Turn off AutoFilter.
    If ws.AutoFilterMode Then ws.AutoFilterMode = False 
    
    ' 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

即使您的 Excel 版本接受 UNIQUE 和 Sort 公式，然后再接受 WorksheetFunction 方法，它们都不会运行确切地作为 Excel 各自的公式...

WorksheetFunction.UNIQUE 不适用于不连续的范围。 下一行，返回这样一个范围：

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

由于上述行为，即使 ListUniq = WorksheetFunction.sort(rang1) 也不起作用。如果 ListUniq 是一个连续的范围，它将起作用。

然后，声明 Dim ListUniq() 会使行 ReDim ListUniq(WorksheetFunction.CountA(rang2)) 变得无用，无论如何它使用了一个不存在的范围。可能是一个类型，应该是rang1，但还是没用。 VBA 能够返回数组不需要以前的ReDim.只有范围是连续的。

在这种情况下，将不连续范围转换为连续数组的函数可以解决您的问题：

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

它可以在您的代码中用作：

   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)...

但是，如果您的 Excel 版本无法处理 Unique 和 Sort，则没有标准的 VBA 函数可以非常快速地处理。如果是这种情况，我也可以发布此类功能。