Sub PopulateCCs()
Const sPath As String = "I:\COL\COL Passport - Template.docm" '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 = False

Set xlSheet = ActiveSheet
With xlSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lngIndex = 2 To LastRow
For Each oCC In wdDoc.ContentControls

wdDoc.ContentControls("Location").Range.Text = Sheets("H").Cells(r, 2)
wdDoc.ContentControls("COLREF").Range.Text = Sheets("A").Cells(r, 2)
wdDoc.ContentControls("OCU").Range.Text = Sheets("X").Cells(r, 2)
wdDoc.ContentControls("Address").Range.Text = Sheets("H").Cells(r, 2)
wdDoc.ContentControls("ukgridref").Range.Text = Sheets("New Reference").Cells(r, 2)
wdDoc.ContentControls("Northings").Range.Text = Sheets("K").Cells(r, 2)
wdDoc.ContentControls("Eastings").Range.Text = Sheets("J").Cells(r, 2)
wdDoc.ContentControls("Latitude").Range.Text = Sheets("New Reference").Cells(r, 2)
wdDoc.ContentControls("Longitude").Range.Text = Sheets("New Reference").Cells(r, 2)
wdDoc.ContentControls("ESN Users").Range.Text = Sheets("New Reference").Cells(r, 2)

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