Option Explicit

Public Function xlFillCCList(strBoxTitle As String, _
                             iColumn As Long, _
                             strWorkbook As String, _
                             strRange As String, _
                             RangeIsWorksheet As Boolean, _
                             RangeIncludesHeaderRow As Boolean)

'Graham Mayor - http://www.gmayor.com - Last updated - 11 April 2019
'strBoxTitle is the name of the list or combo box content control to be filled
'iColumn is the column in the sheet (or the range) to be displayed in the list/combo box
'Columns are numbered starting from 0 i.e. Column A would be iColumn = 0
'strWorkbook is the full path of the workbook containing the data
'strRange is the name of the worksheet or named range containing the data
'RangeIsWorksheet - set to True if the range 'strRange' is a worksheet
' or False if it is a named range
'RangeIncludesHeaderRow - Set to True is the Worksheet or named range contains a header row


Dim RS As Object
Dim CN As Object
Dim oCC As ContentControl
Dim NumRecs As Long, lngRec As Long
Dim strWidth As String
Dim arr() As Variant

    If RangeIsWorksheet = True Then
        strRange = strRange & "$]"
    Else
        strRange = strRange & "]"
    End If

    Set CN = CreateObject("ADODB.Connection")


    If RangeIncludesHeaderRow Then
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                  "Data Source=" & strWorkbook & ";" & _
                                  "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    Else
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                  "Data Source=" & strWorkbook & ";" & _
                                  "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"
    End If

    Set RS = CreateObject("ADODB.Recordset")
    RS.CursorLocation = 3

    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1    'read the data from the worksheet

    With RS
        .MoveLast
        NumRecs = .RecordCount
        .MoveFirst
    End With

    arr = RS.getrows(NumRecs)

    For Each oCC In ActiveDocument.ContentControls
        If oCC.TITLE = strBoxTitle Then
            With oCC
                .DropdownListEntries.Clear
                For lngRec = 0 To UBound(arr, 2)
                    .DropdownListEntries.Add arr(iColumn, lngRec)
                Next lngRec
            End With
            Exit For
        End If
    Next oCC
lbl_Exit:
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
    Set oCC = Nothing
    Exit Function
End Function

Sub Macro1()
xlFillCCList "ContentControl Title", 0, "C:\Path\Datasheet.xlsx", "Worksheet Name", True, True
End Sub