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