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
Const sPassword As String = "MyPassword"

    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)
    If Not wdDoc.ProtectionType = -1 Then
        wdDoc.Unprotect Password:=sPassword
    End If

    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
                oCC.LockContents = False
                If UCase(oCC.Title) = UCase(.Cells(lngIndex, 1)) Then
                    oCC.Range.Text = .Cells(lngIndex, 2)
                    Exit For
                End If
                oCC.LockContents = True
            Next oCC
        Next lngIndex
    End With
    wdDoc.Protect Type:=3, Password:=sPassword
lbl_Exit:
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set oCC = Nothing
    Exit Sub
End Sub