Option Explicit
Dim StrData As String, i As Long

Private Sub Doc()
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook, StrWkBkNm As String
StrWkBkNm = ThisDocument.Path & "\dados.xlsx"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
With xlApp
  .Visible = False
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMRU:=False)
  With xlWkBk
    With .Worksheets(1)
      For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
        StrData = StrData & vbCr & Trim(.Range("A" & i))
        If Trim(.Range("B" & i)) <> "" Then StrData = StrData & " n.º " & Trim(.Range("B" & i))
      Next
    End With
    .Close False
  End With
  .Quit
End With
Call AddControls
Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub

Private Sub Document_ContentControlOnExit(ByVal CCtrl As ContentControl, Cancel As Boolean)
Application.ScreenUpdating = False
Dim i As Long
With CCtrl
  If .Title = "ID" Then
    If .Range.Text <> .PlaceholderText Then .Delete
  End If
End With
Application.ScreenUpdating = True
End Sub

Sub AddControls()
Application.ScreenUpdating = False
Dim CCtrl As ContentControl
If StrData = "" Then
  Call Doc
  Exit Sub
End If
With Selection.Range
  .Collapse wdCollapseStart
  Set CCtrl = .ContentControls.Add(wdContentControlComboBox)
  With CCtrl
    .Title = "ID"
    .SetPlaceholderText Text:="pressione Alt+Seta para baixo"
    For i = 1 To UBound(Split(StrData, vbCr))
      .DropdownListEntries.Add Text:=Split(StrData, vbCr)(i)
    Next
  End With
End With
Application.ScreenUpdating = True
End Sub

If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If