使用 UDF 在单元格中定义下拉列表（数据验证）

Posted 2023-04-13

【中文标题】使用 UDF 在单元格中定义下拉列表（数据验证）

【英文标题】：Use UDF to define a dropdown list (data validation) in a cell

【发布时间】：2021-09-26 21:54:16

【问题描述】：

下午好。 我正在尝试编写函数以将列表输出到单元格（使用数据验证的下拉列表）。

假设指定了一个列表，其中元素根据以下结构进行编码：父指针|指向儿童的指针| 高分辨率照片| CLIPARTO项目文本。

目前，该函数只准备好了一半，只能读取指定的列表。但是已经到了这个阶段，我想测试一下，尝试通过单元格的勾选添加一个下拉列表。

无法直接执行此操作，我尝试通过命名范围添加。

我不是要求结束该功能，而是要求您建议如何制作下拉列表。也许我的函数没有返回任何东西（尽管它确实返回了一个数组）。如何将我的计划付诸实施？

    'Definition of structure
Type Node
    Name As String
    ID As Long
    Level As Long
    ChildrenMas() As Long 'an array of links to child Nodes
    Parent As Long 'indicates a link to the parent
    ParentMarker As String  'indicates the parent symbol
    ChildrenMarker As String 'indicates the symbol that children expect for this parent
    ThisIsRoot As Boolean 'For the root - true, for the rest - false
    DeepCount As Long ' Number of offspring in all subsequent generations
    UsedInFinalTree As Boolean 'the attribute is set at the time of determining the place in the tree for the node
End Type
Type Tree
    Name As String
    ElementsCount As Long
    Levels As Long
    
End Type


Function MultilevelList(Range As Range, _
                                Optional Delimiter As String = "|", _
                                Optional Levell As Long = 0, _
                                Optional OutputInformation As String = "text")


    ReDim RangeAsString(1 To Range.Count) As String
    Dim RangeAsStringCount As Long
    Dim c As Range
    Dim NodesArray() As Node 'an array of tree nodes
    Dim ReturnedNodesArray() As Node 'an array of tree nodes for output
    Dim ReturnedNodesArrayNames() As String
    Dim m As Node
    Dim NewTree As Tree 'creating a tree
    Dim i, j, k, SLong As Integer
    Dim S As String
    Dim a() As String 'array to divide the string
    Dim tm, td As Boolean
    
    i = 1
    For Each c In Range
        RangeAsString(i) = c.Text
        i = i + 1
    Next c
    RangeAsStringCount = Range.Count
    NewTree.Name = "Tree"
    
    'define the length of the array as the length of the resulting Range of strings
    ReDim NodesArray(1 To UBound(RangeAsString))
    For i = 1 To UBound(NodesArray)
        NodesArray(i).ParentMarker = "_none_ParentMarker" & i
        NodesArray(i).ChildrenMarker = "_none_ChildrenMarker" & i
    Next i
    
    
    k = 1
    For i = 1 To UBound(RangeAsString)
        SLong = 0
        S = RangeAsString(i)
        For j = 1 To Len(S)
            If Delimiter = Mid(S, j, 1) Then SLong = SLong + 1
        Next
        If SLong >= 2 Then
            a = Split(S, Delimiter, 3)
            NodesArray(k).ID = k
            NodesArray(k).ParentMarker = a(0)
            NodesArray(k).ChildrenMarker = a(1)
            NodesArray(k).Name = a(2)
            If NodesArray(k).ParentMarker = "" Then
                NewTree.Levels = 1
                NewTree.ElementsCount = NewTree.ElementsCount + 1
                NodesArray(k).Level = 1
                NodesArray(k).ThisIsRoot = True
                NodesArray(k).UsedInFinalTree = True
                RangeAsString(i) = Empty
                RangeAsStringCount = RangeAsStringCount - 1
            End If
            If i + 1 <> UBound(RangeAsString) Then k = k + 1
        Else
            RangeAsString(i) = Empty
            RangeAsStringCount = RangeAsStringCount - 1
        End If
    Next i
    
    tm = False
    Do Until RangeAsStringCount < 1
        If tm = True Then Exit Do
        td = False
        For i = 1 To UBound(NodesArray)
            If NodesArray(i).Level = 0 Then
                For j = 1 To UBound(NodesArray)
                    If NodesArray(i).ParentMarker = NodesArray(j).ChildrenMarker And _
                      NodesArray(j).Level <> 0 Then
                        If IsNotEmptyArray(NodesArray(j).ChildrenMas) Then
                            k = UBound(NodesArray(j).ChildrenMas)
                            ReDim Preserve NodesArray(j).ChildrenMas(1 To UBound(NodesArray(j).ChildrenMas) + 1)
                            k = k + 1
                            NodesArray(j).ChildrenMas(k) = i
                            NodesArray(i).Level = NodesArray(j).Level + 1
                            NodesArray(i).UsedInFinalTree = True
                            NodesArray(i).Parent = j
                            RangeAsStringCount = RangeAsStringCount - 1
                            td = True
                        Else
                            k = 0
                            ReDim Preserve NodesArray(j).ChildrenMas(1 To 1)
                            NodesArray(j).ChildrenMas(1) = i
                            NodesArray(i).Level = NodesArray(j).Level + 1
                            NodesArray(i).UsedInFinalTree = True
                            NodesArray(i).Parent = j
                            RangeAsStringCount = RangeAsStringCount - 1
                            td = True
                        End If
                        B = B
                    End If
                Next j
            End If
            Debug.Print i
            If td = False Then RangeAsStringCount = RangeAsStringCount - 1
        Next i
    Loop

    ReDim ReturnedNodesArray(1 To UBound(NodesArray))
    ReDim ReturnedNodesArrayNames(1 To UBound(NodesArray))
    k = 0
    For i = 1 To UBound(NodesArray)
        If Levell = 0 Then
            If NodesArray(i).UsedInFinalTree = True Then
                k = k + 1
                ReturnedNodesArray(k) = NodesArray(i)
                ReturnedNodesArrayNames(k) = ReturnedNodesArray(k).Name
            End If
        Else
            If NodesArray(i).Level = Levell And NodesArray(i).UsedInFinalTree = True Then
                k = k + 1
                ReturnedNodesArray(k) = NodesArray(i)
                ReturnedNodesArrayNames(k) = ReturnedNodesArray(k).Name
            End If
        End If
    Next i
    ReDim Preserve ReturnedNodesArray(1 To k)
    ReDim Preserve ReturnedNodesArrayNames(1 To k)
    
    B = UBound(RangeAsString)
   
    If OutputInformation = "text" Then
        MultilevelList = WorksheetFunction.Transpose(ReturnedNodesArrayNames)
        'MultilevelList = ReturnedNodesArrayNames
    End If
    
    
End Function

'function to check the initialized youth of the array
Function IsNotEmptyArray(parArray As Variant) As Boolean
  On Error Resume Next
  IsNotEmptyArray = LBound(parArray) <= UBound(parArray)
End Function

Example file

【问题讨论】：

您能否编辑您的问题以包括：1. 什么类型的下拉列表（数据验证、用户窗体控件等），以及 2. 您的函数的代码。

@Ambie 纠正并纠正了一切

【参考方案1】：

在我的示例中，我正在创建一个包含 UDF 月份的简单列表

Option Explicit

Public Function arrValues() As Variant
Dim i As Long

Dim arr(1 To 12, 1 To 1) As Variant   'two-dimensional array to get vertical list
For i = 1 To 12
    arr(i, 1) = MonthName(i)
Next
    
arrValues = arr
End Function

根据我的测试：您必须将结果放在工作表上。

为 B2 添加一个名称 - 该名称仅引用 B2 并且必须在末尾有一个 # 符号 - 因为这是一个数组公式：

现在您可以使用 lstArrValues 作为验证列表。

【讨论】：

是的，我也来到了这个选项 - 将它卸载到一张纸上，例如，一张桌子，然后简单地引用它。但是，此选项有缺点，例如，对于每个多级选择，您将需要使用其自己的单独表格。并且要求UDF的结果可以立即落入下拉列表中。

你能告诉我们更多关于#的信息吗？我以前没有遇到过。

验证列表不适用于 UDF 作为列表。它也不适用于数组公式。这就是为什么您必须先将内容写在一张纸上并为其命名。关于 #：它是溢出的范围运算符 - support.microsoft.com/en-us/office/…（这对 office 365 有效！）

【参考方案2】：

从您的 cmets 看来，您也在关注子列表。如果是这种情况，那么使用纯 VBA 解决方案可能会更好（而不是将数组写入命名范围）。

我很确定 ike 是正确的，即不能在 list 参数中引用 UDF 或数组公式。

如果您对 VBA 解决方案感兴趣，那么它看起来像这样：

Option Explicit

Public Sub SetTopValidationList()
    Dim items As Variant
    Dim formulaText As String
    
    'This is your array of validation items.
    items = Array(1, 2, 3)
    
    'The formula parameter needs a comma separated string.
    formulaText = Join(items, ",")
    
    'Add the validation.
    With Sheet1.Range("B2").Validation
        .Delete
        .Add xlValidateList, xlValidAlertStop, xlBetween, formulaText
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Public Sub SetSubValidationList(topItem As Variant)
    Dim items As Variant
    Dim formulaText As String
    
    If IsEmpty(topItem) Then
        With Sheet1.Range("B4")
            .Validation.Delete
            .ClearContents
        End With
        Exit Sub
    End If
    
    Select Case topItem
        Case 1: items = Array(10, 11, 12)
        Case 2: items = Array(20, 21, 22)
        Case 3: items = Array(30, 31, 32)
        Case Else: items = Empty
    End Select
    
    If IsEmpty(items) Then
        With Sheet1.Range("B4")
            .Validation.Delete
            .ClearContents
        End With
        Exit Sub
    End If
    
    formulaText = Join(items, ",")
    With Sheet1.Range("B4").Validation
        .Delete
        .Add xlValidateList, xlValidAlertStop, xlBetween, formulaText
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    
End Sub

您只需在工作表后面的代码中捕获***更改，例如：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Me.Range("B2"), Target) Is Nothing Then
        SetSubValidationList Me.Range("B2").Value2
    End If
End Sub

【讨论】：

该解决方案的问题可能是公式 1 限制为 255 个字符

@ike，好点。