Microsoft Office Forums - View Single Post - [Solved] How to create multilevel drop-down list in word

edeszti · 06-08-2020, 01:24 AM

Hi,

I want to add multilevel (3-level) dependent drop-down lists to a word document which imports the data from excel cells.
I used the logic of this excel example:
VBA: Multilevel dependent drop-down in User Form - PK: An Excel Expert

There are three content controls in the word document: Category, Sub Category and Item. The content of the Sub Category drop-down list depends on the selected value of the Category drop-down list, and the content of the Item drop-down list depends on the selected value of the Sub Category drop-down list.
My problem is that the macro doesn't update the Sub Category and the Item drop-down lists. I use Document_ContentControlOnExit event.

I attach the .docm and the excel.
Code:

Code:

Private Sub Document_ContentControlOnExit(ByVal CCtrl As ContentControl, Cancel As Boolean)
Application.ScreenUpdating = False

Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
Dim StrWkBkNm As String, StrWkShtNm As String, LRow As Long, i As Long

StrWkBkNm = "c:\.....\teszt_lista.xlsx"
StrWkShtNm = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
Dim cc1 As ContentControl, cc2 As ContentControl, cc3 As ContentControl

Set cc1 = ActiveDocument.SelectContentControlsByTitle("Category").Item(1)
Set cc2 = ActiveDocument.SelectContentControlsByTitle("SubCategory").Item(1)
Set cc3 = ActiveDocument.SelectContentControlsByTitle("Item").Item(1)

xlApp.Visible = False
Set xlWkBk = xlApp.Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMRU:=False)
LRow = xlWkBk.Worksheets(StrWkShtNm).Cells(.Rows.Count, 1).End(xlUp).Row

With CCtrl
    Select Case .Title
        Case "Category"
            cc2.DropdownListEntries.Clear
            For i = 2 To LRow
                If Trim(.Range("A" & i)) = "Sub Category" Then
                    If Trim(.Range("C" & i)) = .Range.Text Then
                        cc2.DropdownListEntries.Add Text:=Trim(.Range("B" & i))
                    End If
                End If
            Next
        Case "SubCategory"
            cc3.DropdownListEntries.Clear
            For i = 2 To LRow
                If Trim(.Range("A" & i)) = "Item" Then
                    If Trim(.Range("C" & i)) = .Range.Text Then
                        cc3.DropdownListEntries.Add Text:=Trim(.Range("B" & i))
                    End If
                End If
            Next
    End Select
End With
xlWkBk.Close False
xlApp.Quit
Application.ScreenUpdating = True
 End Sub

Thanks a lot in advance