使用命名范围使用 vba 创建 excel 数据验证

Question

I have the following code:

Function createCascadingDropDown(sourceTable As ListObject, targetTable As ListObject, targetTableCorespondingColumn As Integer, targetWs As Worksheet, targetWsDropDownColumn As Integer)
    Dim currentDropDownList As String, dropDownName As String, formula As String
    Dim validationVariable As Validation
    currentDropDownListName = targetWs.Name & "CurrentDropDownList"
    dropDownName = targetWs.Name & "DropDown"
    targetWs.Names.Add Name:=currentDropDownListName, RefersToLocal:="=INDEX(" & targetWs.Name & "!" & currentDropDownListName & ";1;1):INDEX(" & targetWs.Name & "!" & currentDropDownListName & ";COUNTA(" & targetWs.Name & "!" & currentDropDownListName & "))"
    targetWs.Names.Add Name:=dropDownName, RefersToLocal:="=INDEX(" & sourceTable.Name & ";0;MATCH(INDEX(" & targetTable.Name & "[@];" & CStr(targetTableCorespondingColumn) & ");" & sourceTable.Name & "[#Headers];0))"
    formula = "=" & dropDownName
    With targetWs.columns(targetWsDropDownColumn).EntireColumn.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=formula
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .InputMessage = ""
        .ErrorTitle = ""
        .ErrorMessage = ""
        .ShowInput = False
        .ShowError = True
    End With
    targetWs.Cells(1, targetWsColumn).Validation.Delete
End Function

In general I am trying to programmatically build up a cascading drop-down-menu like in https://www.contextures.com/exceldatavaldependindextables.html .

The problem occurs in the line where I add the validation. Here the error "Application-defined or object-defined error" comes up.

When I add a break point and do this step manually it works, despite the fact, that excel tells me "The source currently evaluates to an error. Do you want to continue?". It might be that this is the problem; at least I found this and this , which both did not help. Wrapping IFERROR around the formula makes it invalid.

So I also tried to set the RefereToLocal to an empty cell (eg "=$A$20") and change it afterwards. Now the problem is, that it does not accept the exact same formula again:

targetWs.Names.Item(dropDownName).RefersToLocal ="=INDEX(" & targetWs.Name & "!" & currentDropDownListName & ";1;1):INDEX(" & targetWs.Name & "!" & currentDropDownListName & ";COUNTA(" & targetWs.Name & "!" & currentDropDownListName & "))"

I am really running out of ideas. In case you have any to solve also the original problem (implement a vba-free cascading drop-down using vba) I would be happy to about them!

Answer 1

Since nobody around here got an idea up to now I guess this problem is fairly hard to solve or not solvable. In case anybody else wants to create cascading drop-down menus programmatically, here is a workaround, that works without tables, since I think the tables were the problem. By the way it is possible to format the worksheet as table afterwards :

Function createCascadingDropDown(sourceWs As Worksheet, targetWs As Worksheet, targetCorespondingColumn As Integer, targetDropDownColumn As Integer, sourceNumberOfRowsPerColumnAs Object)
    Dim numberOfColumns As Integer, numberOfRows As Integer, targetLastRow As Long
    Dim targetCorespondingColumnSecondRowRange As String, valDataName As String, counterName As String, useListeName As String
    valDataName = "ValData" & sourceWs.Name
    counterName = "Counter" & sourceWs.Name
    useListeName = "UseListe" & sourceWs.Name
    targetLastRow = targetWs.Rows.CountLarge
    numberOfCulumns = sourceNumberOfRowsPerColumn.Count
    'Get the maximum number of rows in the source worksheet
    numberOfRows = 0
    For Each columnKey In sourceNumberOfRowsPerColumn.Keys
        If sourceNumberOfRowsPerColumn(columnKey) > numberOfRows Then
            numberOfRows = sourceNumberOfRowsPerColumn(columnKey)
        End If
    Next columnKey
    targetCorespondingColumnSecondRowRange = targetWs.Cells(1, targetCorespondingColumn).Address(RowAbsolute:=False, ColumnAbsolute:=True)
    targetWs.Names.Add Name:=counterName, RefersTo:="=COUNTA(INDEX(" & valDataName & ",,MATCH(" & targetWs.Name & "!" & targetCorespondingColumnSecondRowRange & "," & sourceWs.Name & "!$1:$1,0)))"
    targetWs.Names.Add Name:=useListeName, RefersTo:="=INDEX(" & valDataName & ",1,MATCH(" & targetWs.Name & "!" & targetCorespondingColumnSecondRowRange & "," & sourceWs.Name & "!$1:$1,0)):INDEX(" & valDataName & "," & counterName & ",MATCH(" & targetWs.Name & "!" & targetCorespondingColumnSecondRowRange & "," & sourceWs.Name & "!$1:$1,0))"
    With targetWs.Range(targetWs.Cells(2, targetDropDownColumn), targetWs.Cells(targetLastRow, targetDropDownColumn)).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & useListeName
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .InputMessage = ""
        .ErrorTitle = ""
        .ErrorMessage = ""
        .ShowInput = False
        .ShowError = True
    End With
End Function

Where sourceNumberOfRowsPerColumn has to be a dictionary and the Master -column is created elsewhere in the column targetCorespondingColumn . Also this solution allows only one cascading-step and the source of the Master -column is in a different worksheet.

As a basis for this solution I took the example from https://www.contextures.com/xlDataVal15.html .