CODEWITHSUNDEEP
excelvba
Peter Beckett
Peter Beckett

Reputation: 13

Alternatives to using the AdvancedFilter property of the Range object

I am using the AdvancedFilter property of a Range object to copy a unique set of values to another range within my workbook. Unfortunately, the ActiveSheet has an autofilter applied and the AdvancedFilter statement removes the autofilter from the ActiveSheet. As you will see in my code below I can add the autofilter back onto the ActiveSheet but this feels a little 'clunky'. Could anyone suggest an alternative coding solution?

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

Upvotes: 0

Views: 219

Answers (1)

Rory
Rory

Reputation: 34045

Here's an example of Dictionary use:

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

Upvotes: 1

Related Questions