Создать уникальный список из столбца, отображать результаты в раскрывающемся списке, используя панель ленты, отображать фильтр на рабочем листе.

Question

У меня есть 29 000 строк плюс на листе DataCalcs.В столбце AG у меня есть следующие значения:

Altern 1
Altern 1
Altern 1
Altern 1
Altern 1
Altern 1
Base   2
Base   2
Base   2
Base   2
Base   2

и т. Д. В столбце AG

Мне нужен код, который отфильтрует эти данные и отобразит то, что отфильтровано изПользовательское меню, которое я создал на ленте Excel.

Мне также нужно, чтобы данные отображались на рабочем листе DataCalcs, когда выбрано меню в раскрывающемся меню на панели ленты на основе уникальных выборок в столбце.AG, которые фильтруются.

Я также сохранил эти данные в диапазоне, называемом DataCalcs, поэтому, пожалуйста, не стесняйтесь использовать этот именованный диапазон в коде.

Спасибо за просмотр и чтение!

Answer 1

Эти процедуры делают работу: Sub AdvFilter на самом деле всего одна строка кода.Sub AdvFilterSort включает возможность сортировки результата.

Option Explicit

'Sub AdvFilter and Sub AdvFilterSort
'based on https://stackoverflow.com/questions/32787227/vba-advanced-filter-unique-values-and-copy-to-another-sheet

Sub AdvFilter(InputRange As Range, OutputRange As Range)
    InputRange.AdvancedFilter Action:=xlFilterCopy, copytorange:=OutputRange, Unique:=True
End Sub

Sub AdvFilterSort(InputRange As Range, OutputRange As Range, Optional sortHeader As Integer, Optional sortAscOrDesc As Integer)
    Dim sortRange As Range
    InputRange.AdvancedFilter Action:=xlFilterCopy, copytorange:=OutputRange, Unique:=True
    If sortAscOrDesc = xlAscending Or sortAscOrDesc = xlDescending Then
        Set sortRange = OutputRange.CurrentRegion
        sortRange.Sort key1:=OutputRange, Order1:=sortAscOrDesc, Header:=sortHeader
    End If
End Sub

Эта процедура вызывает AdvFilter / AdvFilterSort с вашими данными «DataCalcs»:

Option Explicit

Sub Call_AdvFilter()
    Dim agRange As Range
    Dim lastRow As Long

    'Create a new sheet for the results : "newSheet"

    If sheetExists("newSheet") Then
        'nothing to do
    Else
        'create sheet and name it "newSheet"
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = "newSheet"
    End If
    lastRow = Worksheets("DataCalcs").Range("A1").SpecialCells(xlCellTypeLastCell).Row
    Set agRange = Range("DataCalcs!AG1:AG" & lastRow)

    'Delete result columns
    Range("newsheet!A:H").Delete

    With Worksheets("newSheet")
        .Range("A1:H3").Font.Bold = True
        .Range("A1:H1").Font.Size = 14
        .Range("A3:H3").Font.Size = 12

        'using column ag data defined with lastrow
        .Range("A1").Value = "Column AG data (lastrow):"

        'result sorted:
        .Range("A3").Value = "sorted"
        Call AdvFilterSort(Range("DataCalcs!AG1:AG3340"), .Range("A5"), xlNo, xlAscending)

        'result not sorted:
        .Range("C3").Value = "not sorted"
        Call AdvFilter(Range("DataCalcs!AG1:AG3340"), .Range("C5"))


        'using predefined range named "DataCalcs"
        .Range("F1").Value = "defined Name ""DataCalcs"":"

        'result sorted:
        .Range("F3").Value = "sorted"
        Call AdvFilterSort(Range("DataCalcs"), .Range("F5"), xlNo, xlAscending)

        'result not sorted:
        .Range("H3").Value = "not sorted"
        Call AdvFilter(Range("DataCalcs"), .Range("H5"))

    End With
End Sub

Это хорошая функция sheetExists, использованная выше:

Function sheetExists(sheetToFind As String) As Boolean
    'copied from:
    'https://stackoverflow.com/questions/6040164/excel-vba-if-worksheetwsname-exists
    'by Dante is not a Geek
    'https://stackoverflow.com/users/571433/dante-is-not-a-geek
    Dim mySheet As Worksheet
    sheetExists = False
    For Each mySheet In Worksheets
        If sheetToFind = mySheet.Name Then
            sheetExists = True
            Exit Function
        End If
    Next mySheet
End Function