具有多个标准排名的 Excel VBA 动态数据验证下拉列表

Posted 2023-05-08

【中文标题】具有多个标准排名的 Excel VBA 动态数据验证下拉列表

【英文标题】：Excel VBA Dynamic data validation drop downs with multiple criteria ranking

【发布时间】：2018-07-05 19:26:16

【问题描述】：

我正在尝试创建一个动态下拉数据验证列表，该列表将对工作表中的多个标准（#2 或更多）进行排名，我的列表中有 300 个项目，我想根据另一个工作表中的信息对它们进行排名一张桌子。

根据排名（1 到 300），我希望下拉数据验证列表包含根据排名计算的前 10、前 25 和顶部/底部 # 值。我不介意帮助列。如果我排名的数据/表格发生变化，和/或如果我想添加一个标准，我希望前 10 名、前 25 名等进行相应更改。

我在使用高级过滤器时使用宏记录器进行了记录，并且在这种情况下也是前 25 个值。

Sub Makro2()
Selection.AutoFilter
Range("T[#All]").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
    Range("A1:J3"), Unique:=False

Range("T[[#Headers],[2017]]").Select
ActiveSheet.ShowAllData

Selection.AutoFilter

ActiveSheet.ListObjects("T").Range.AutoFilter Field:=2, Criteria1:="25", _
    Operator:=xlTop10Items
End Sub

在带有或不带有 VBA 的 Excel 2016 中这可能吗？

编辑：我找到了这个线程Data Validation drop down list not auto-updating，而那个线程中的这段代码可能就是我要找的。​​p>

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' Ensure all lists are made from tables and that these tables are named
' in the Name Manager.
' When creating your Data Validation List, instead of selecting a range
' in 'Source', click within 'Source' and press 'F3'. Finally select your
' tables name.
Dim strValidationList As String
Dim strVal As String
Dim lngNum As Long

On Error GoTo Nevermind
strValidationList = Mid(Target.Validation.Formula1, 2)
strVal = Target.Value
lngNum = Application.WorksheetFunction.Match(strVal, ThisWorkbook.Names(strValidationList).RefersToRange, 0)

' Converts table contents into a formula
If strVal <> "" And lngNum > 0 Then
    Application.EnableEvents = False
    Target.Formula = "=INDEX(" & strValidationList & ", " & lngNum & ")"
End If

Nevermind:
    Application.EnableEvents = True

End Sub

更新：

我正在使用 LARGE 函数来获取 Table1 的前 15 个值。然后我使用 INDEX 和 MATCH 来查找前 15 个值的名称（第 2 列）。

然后我使用 OFFSET 函数和一个 NAMED RANGE 来获取一个数据验证列表，当我在列表底部添加一些内容时该列表会自动更新。

现在我希望数据验证列表依赖于第一个下拉列表。我怎样才能做到这一点？

【问题讨论】：

目前我正在使用 Excel 的高级过滤器来过滤两个条件，按大小排序，然后使用 RANK 进行排名

AutoFilter 已经允许按“Top”# 或 % 进行过滤。这是tutorial。

感谢您的教程。如何使用动态（非手动更新）数据验证列表中的顶部 # 或 %？

@wairmea 我发现使此类事情自动化（并在此过程中学习）的最简单方法是手动使其工作，记录您的操作，并根据需要调整记录的代码。我不确定您要动态更改什么（因为问题不包括详细信息或示例或示例数据）

如果您已经熟悉 Excel，请参阅：Recording a Macro to Generate Code 和 Revising Recorded Visual Basic Macros。如果您不熟悉 Excel（或您计划使用 VBA 自动化的任何内容），请在尝试 VBA 之前执行此操作。这个 VBA 教程也不错：Excel VBA For Beginners 和 Microsoft's Documentation。

【参考方案1】：

您正在正确地处理它，在加载列表之前对列表数据进行排序或过滤。我对您的问题感到困惑，但您似乎想知道在操作列表后如何创建数据验证下拉菜单？

这是一个示例，说明如何通过编写简单的测试代码来构建州列表，然后根据所选州构建县列表。也许这可以帮助您建立验证列表。

有两个工作表：

1) 一个用于数据列表项 ThisWorkbook.Worksheets("DataList")

2) 下拉菜单 ThisWorkbook.Worksheets("DD Report Testing")

在模块 Create_State_List 中

Option Explicit

'This is a two part validation, select a state and then select a county

Sub CreateStateList()
   Dim FirstDataRow As Double, LastDataRow As Double
   Dim StateCol As Double, CountyCol As Double
   Dim DataListSht As Worksheet
   Dim DDReportSht As Worksheet

   Dim StateListLoc As String
   Dim StateRange As Range

   Set DataListSht = ThisWorkbook.Worksheets("DataList")
   Set DDReportSht = ThisWorkbook.Worksheets("DD Report Testing")
   FirstDataRow = 3 'First row with a State
   StateCol = 2 'States are in Col 2 ("B")
   LastDataRow = DataListSht.Cells(DataListSht.Rows.Count, StateCol).End(xlUp).Row

   Set StateRange = DataListSht.Range(DataListSht.Cells(FirstDataRow, StateCol), DataListSht.Cells(LastDataRow, StateCol))

   StateListLoc = "D3" 'This is where the drop down is located / will be updated

   DDReportSht.Range(StateListLoc).ClearContents 'Clear the list as we build dynamically
   DDReportSht.Range(StateListLoc).Validation.Delete 'Clear the Validation

   'Create the State List
   With Range(StateListLoc).Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=DataList!" & StateRange.Address
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With

End Sub

在模块 Create_County_List 中

Option Explicit

Private Sub CreateCountyList(StateChosen As String)

    Dim DataListSht As Worksheet
    Dim DDReportSht As Worksheet
    Dim StateRow As Double
    Dim NumStateCols As Double
    Dim StartStateCol As Double
    Dim i As Integer
    Dim LastDataRow As Double
    Dim CountyRange As Range
    Dim CountyListLoc As String

    Set DataListSht = ThisWorkbook.Worksheets("DataList")
    Set DDReportSht = ThisWorkbook.Worksheets("DD Report Testing")
    NumStateCols = 51 'We count the District of Columbia
    StateRow = DataListSht.Range("C2").Row
    StartStateCol = DataListSht.Range("C2").Column

    For i = 0 To NumStateCols 'Account for starting at zero rather than 1

        If CStr(Trim(DataListSht.Cells(StateRow, StartStateCol + i))) = StateChosen Then
            'find the last Data row in the column where the match is
            LastDataRow = DataListSht.Cells(DataListSht.Rows.Count, StartStateCol + i).End(xlUp).Row

            'Make the Dynamic list of Counties based on the state chosen
            Set CountyRange = DataListSht.Range(DataListSht.Cells(StateRow + 1, StartStateCol + i), DataListSht.Cells(LastDataRow, StartStateCol + i))

            CountyListLoc = "D4"

            DDReportSht.Range(CountyListLoc).ClearContents
            DDReportSht.Range(CountyListLoc).Validation.Delete

            'Create the County List
            With Range(CountyListLoc).Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="=DataList!" & CountyRange.Address
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With

           'Break loop
           i = 1000 ' should break loop off right here
        Else 'do not build a list
        End If
    Next i

End Sub

工作表包含单元格选择代码

Option Explicit

'This routine will react to changes to a cell in the worksheet
Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim DDReportSht As Worksheet
    Dim StateString As String
    Set DDReportSht = ThisWorkbook.Worksheets("DD Report Testing")

    Call CheckStatusBar 'Lets update the Status bar on selection changes

    'If the cell change is D3 on DD report (they want state so build list for state)
    If Not Intersect(Target, DDReportSht.Range("D3")) Is Nothing Then
            'Clear the county list until the state is chosen to avoid mismatch
            DDReportSht.Range("D4").ClearContents
            DDReportSht.Range("D4").Validation.Delete

            '*** Create the State Drop Down
            Call CreateStateList

    Else 'Do nothing
    End If


    'If the cell change is D4 on DD report (they want the county list so build it based on the state in D3)
    If Not Intersect(Target, DDReportSht.Range("D4")) Is Nothing Then
        'If there was a change to the state list go get the county list set up
        StateString = DDReportSht.Range("D3")
        Application.Run "Create_County_List.CreateCountyList", StateString
    Else 'Do nothing
    End If

    'If cell is D7 build a rig list
    If Not Intersect(Target, DDReportSht.Range("D7")) Is Nothing Then
        'Build the Rig List
        Call CreateRigList
    Else 'Do nothing
    End If

End Sub

数据集：

在实践中测试验证工作表，这只是一个演示：

【讨论】：

非常感谢您的回复！我刚刚开始学习 VBA，但我运行了你的代码，但是我只得到一个数据验证下拉菜单（在单元格 #D3 中）？代码确实会动态更新范围，这很棒。您已经对代码进行了注释，但如果您愿意，请告诉我为什么代码在 3 个不同的模块中？

下一个下拉列表位于 D4（县）中，具体取决于先前填写的 D3（州）。 Subs 可能都在工作表代码中，但是当你扩展你的项目时，你会发现如果你想替换来修改、导出或导入模块，你会想要封装你的代码函数，如果你想快速获取它们进入另一个项目，这是最简单的方法。 “解开你的代码依赖关系”尤其重要，因为 VBA 会戏弄你制作一个巨大的超级子，仅供参考 - 给定模块中可以拥有的代码行数或子数是有限制的。

这显示了如何“加载”您的验证列表。如果您可以解释您的数据是什么样的以及您希望如何对其进行排序，我们可以在加载“列表”之前提供过滤和/或排序的示例。有时您使用这种方法，基于 excel 的表单，有时您可能希望弹出一个带有项目列表框的表单供用户选择。另一种方法。

感谢您的回复和代码。我已经根据你的图片设置了我的数据，我也在使用州和县，但是 CountyListLoc 从来没有被调用过？我尝试将 debug.print 添加到几个地方，但没有任何内容打印到即时窗口。我在 DD Report Testing 的单元格 D3 中得到一个动态下拉菜单，但仍然没有 D4？

我认为您的代码正是我想要的以及我的项目所需要的。我在 D3 中选择了一个州，然后将该州的县加载到 D4 中？您能否在两个下拉菜单中上传图片。

【参考方案2】：

编辑：您想将代码更改为 xlDescending，但同样的想法也适用

在触发 worksheet_change 事件之前，我们看到范围未排序。单元格 D1 中显示为选项的前十项是该范围中的前十项。

当我们对 I1:I20 范围内的值进行更改时，我们会触发 worksheet_change 事件。在这个函数中，我们有代码可以对范围 H1:I20 进行排序。

这里是 worksheet_change 函数的代码，它的放置位置位于您正在使用的工作表的工作表模块内

最后是如何将您的数据验证限制与范围相关联。更改范围 H1:I10（也就是前十名）将更改框中的可用选项。

代码的sn-p

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rangeOfTable As Range
            Set rangeOfTable = ActiveSheet.Range("H1:I20")

        If Not Application.Intersect(Target, rangeOfTable) Is Nothing Then
            rangeOfTable.Sort Range("I1:I20"), xlAscending
        End If
End Sub

编辑：也适用于下拉框

编辑：此代码将让您了解 RE 如何对多个值进行排序

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rangeOfTable As Range
            Set rangeOfTable = ActiveSheet.Range("H1:J20")

        If Not Application.Intersect(Target, rangeOfTable) Is Nothing Then
            With rangeOfTable
                .Sort key1:=ActiveSheet.Range("I1:I20"), order1:=xlAscending, _
                    key2:=ActiveSheet.Range("J1:J20"), Order2:=xlAscending
            End With
        End If
End Sub

这是事件触发后的数据，注意列表中的前十个是下拉框中唯一可用的十个

【讨论】：

谢谢你的回复，很聪明！

谢谢！也可以与组合框一起使用（硬推：-p）

它是否适用于可靠的下拉菜单和/或可靠的组合框？

添加了多重排序