Option Explicit
Dim arrData() As Variant
Private Sub Document_ContentControlOnExit(ByVal oCC As ContentControl, Cancel As Boolean)
Dim lngIndex As Long
  Select Case oCC.Title
    Case "Name"
      If Not oCC.ShowingPlaceholderText Then
        'Determine which dropdown list entry was selected. Note: The object model has no direct way to do this.
        For lngIndex = 1 To oCC.DropdownListEntries.Count
          If oCC.Range.Text = oCC.DropdownListEntries.Item(lngIndex) Then Exit For
        Next lngIndex
        'Use that date fill in the transposed name and fill the dependent fields.
        With oCC
          .Type = wdContentControlText
          .Range.Text = arrData(1, lngIndex - 2)
          .Type = wdContentControlDropdownList
        End With
        With ActiveDocument
          'In the Excel data, "~" is used to define linebreaks in the address column.  Replace with linebreaks.
          .SelectContentControlsByTitle("Address").Item(1).Range.Text = Replace(arrData(2, lngIndex - 2), "~", Chr(11))
          .SelectContentControlsByTitle("Phone Number").Item(1).Range.Text = arrData(3, lngIndex - 2)
          .SelectContentControlsByTitle("Email").Item(1).Range.Text = arrData(4, lngIndex - 2)
        End With
      Else
        With ActiveDocument
          'Reset the dependent CCs.
          .SelectContentControlsByTitle("Address").Item(1).Range.Text = vbNullString
          .SelectContentControlsByTitle("Phone Number").Item(1).Range.Text = vbNullString
          .SelectContentControlsByTitle("Email").Item(1).Range.Text = vbNullString
        End With
      End If
    Case Else
  End Select
lbl_Exit:
  Exit Sub
End Sub
Sub Document_Open()
Dim strWorkbook As String, strColumnData As String
Dim lngIndex As Long, lngRowIndex As Long, lngColIndex As Long
'Dim arrData As Variant
Dim oCC As ContentControl
  Application.ScreenUpdating = False
  strWorkbook = "D:\Data Stores\Fill CC from Excel Data Store.xlsx"
  If Dir(strWorkbook) = "" Then
    MsgBox "Cannot find the designated workbook: " & strWorkbook, vbExclamation
    Exit Sub
  End If
  Set oCC = ActiveDocument.SelectContentControlsByTitle("Name").Item(1)
  arrData = fcnExcelDataToArray(strWorkbook, "Data")
  If oCC.DropdownListEntries.Item(1).Value = vbNullString Then
    For lngIndex = oCC.DropdownListEntries.Count To 2 Step -1
      oCC.DropdownListEntries.Item(lngIndex).Delete
    Next lngIndex
  Else
    oCC.DropdownListEntries.Clear
  End If
  For lngRowIndex = 0 To UBound(arrData, 2)
    oCC.DropdownListEntries.Add arrData(0, lngRowIndex), arrData(1, lngRowIndex)
  Next
lbl_Exit:
  Application.ScreenUpdating = True
  Exit Sub
End Sub
Private Function fcnExcelDataToArray(strWorkbook As String, _
                                     Optional strRange As String = "Sheet1", _
                                     Optional bIsSheet As Boolean = True, _
                                     Optional bHeaderRow As Boolean = True) As Variant
Dim oRS As Object, oConn As Object
Dim lngRows As Long
Dim strHeaderYES_NO As String
  strHeaderYES_NO = "YES"
  If Not bHeaderRow Then strHeaderYES_NO = "NO"
  If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
  Set oConn = CreateObject("ADODB.Connection")
  oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
  Set oRS = CreateObject("ADODB.Recordset")
  oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
  With oRS
    .MoveLast
    lngRows = .RecordCount
    .MoveFirst
  End With
  fcnExcelDataToArray = oRS.GetRows(lngRows)
lbl_Exit:
  If oRS.State = 1 Then oRS.Close
  Set oRS = Nothing
  If oConn.State = 1 Then oConn.Close
  Set oConn = Nothing
  Exit Function
End Function