Question

我正在使用Range对象的AdvancedFilter属性将一组唯一的值复制到工作簿中的另一个范围。不幸的是，ActiveSheet应用了自动过滤器，而AdvancedFilter语句从ActiveSheet中删除了自动过滤器。正如您将在下面的代码中看到的那样，我可以将自动过滤器重新添加到ActiveSheet上，但这有点“笨拙”。有人可以建议替代编码解决方案吗？

Sub mmDropDownClasses()
'Populate the 'LU' sheet with a unique range of classes from the currently 
'active sheet

Range("LU!I2:I30").ClearContents        'Clear the range to be populated
ActiveSheet.Unprotect                   'Unprotect the active sheet

'Extract the unique values from a range on the active sheet and copy them 
'to a range on the 'LU' sheet
ActiveSheet.Range("C6:C304").AdvancedFilter Action:=xlFilterCopy, 
CopyToRange:=Range("LU!I2"), Unique:=True

'Reinstate the autofilter deleted by the advancedfilter in the previous 
'statement
ActiveSheet.Range("A5:BA5").AutoFilter
ActiveSheet.Protect AllowFiltering:=True 'Protect the active sheet

'Sort the range on the 'LU' sheet
Range("LU!I2:I30").Sort key1:=Range("LU!I2:I30"), order1:=xlAscending

End Sub

Answer 1

以下是“词典”用法的示例：

Sub testit()
    Dim v
    v = UniqueListFromRange(ActiveSheet.Range("C6:C304"))
    Sheets("LU").Range("I2").Resize(UBound(v) + 1).Value = Application.Transpose(v)
End Sub

Public Function UniqueListFromRange(rgInput As Range) As Variant
    Dim d                     As Object
    Dim rgArea                As Excel.Range
    Dim dataSet
    Dim x                     As Long
    Dim y                     As Long

    Set d = CreateObject("Scripting.Dictionary")

    For Each rgArea In rgInput.Areas
        dataSet = rgArea.Value
        If IsArray(dataSet) Then
            For x = 1 To UBound(dataSet)
                For y = 1 To UBound(dataSet, 2)
                    If Len(dataSet(x, y)) <> 0 Then d(dataSet(x, y)) = Empty
                Next y
            Next x
        Else
            d(dataSet) = Empty
        End If
    Next rgArea
    UniqueListFromRange = d.keys
End Function

使用Range对象的AdvancedFilter属性的替代方法

1 个答案: