Sub PopulateCCs()
Const sPath As String = "c:\path\document name.docx"    'the full path of the document
Dim oCC As Object
Dim wdApp As Object
Dim wdDoc As Object
Dim LastRow As Long, lngIndex As Long
Dim xlSheet As Worksheet
Dim sValue As String

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    ActiveWorkbook.Save
    Set wdDoc = wdApp.Documents.Open(sPath)

    wdApp.Visible = True

    Set xlSheet = ActiveSheet
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For lngIndex = 2 To LastRow
            For Each oCC In wdDoc.ContentControls
                If UCase(oCC.Title) = UCase(.Cells(lngIndex, 1)) Then
                    oCC.Range.Text = .Cells(lngIndex, 2)
                    Exit For
                End If
            Next oCC
        Next lngIndex
    End With
lbl_Exit:
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set oCC = Nothing
    Exit Sub
End Sub