Use UDF to define a dropdown list (data validation) in a cell-CodePudding

good afternoon. I am trying to write my function to output a list to a cell (drop-down list using data validation).

It was assumed that a list is specified where the elements are encoded according to the following structure: parent pointer | pointer to children | Item text.

At the moment, the function is only half ready and is able to read only the specified list. But already at this stage, I wanted to test it and try to add a drop-down list through the check of the cell.

It was not possible to do this directly, and I tried to add through the Named Range.

I am not asking to end the function, however, I am asking you to suggest how to make the dropdown list. Maybe my function does not return something (although it does return an array). How do I get my plan into action?

    '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

Add a name to B2 - the name references B2 only and has to have a #-sign at the end - because this is an array formula:

Now you can use lstArrValues as a validation list.

CodePudding user response：

It sounds, from your comments, that you're also after sub lists. If that's the case, then you might be better off with a pure VBA solution (rather than writing your array to a named range).

I'm pretty sure that ike is correct, ie you can't reference a UDF or array formula in the list parameter.

If the VBA solution interests you, then it would look something like this:

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

And you'd simply trap the top level change in the code behind your worksheet, eg:

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