Sub CreateCCForMatchedText()
'Much thanks to Greg Maxey for doing the hard part
Dim oRng As Word.Range
Dim oQuery As String
Dim oCC As ContentControl
Dim i As Long
Dim oCCTitle As String
Dim oCCTitleAssignment As String
Dim oCancelOperation As Integer
Dim oSameTitle As Boolean

Set oRng = ActiveDocument.Range
oSameTitle = False
oQuery = InputBox("Enter text to bind to Content Controls", "Find and Bind")
  With oRng.Find
    .Text = oQuery
    While .Execute
        'Find the Title for any CC that whose contents match the query
        For i = 1 To ActiveDocument.ContentControls.Count
            If ActiveDocument.ContentControls(i).Range.Text = oQuery Then
            oCCTitle = ActiveDocument.ContentControls(i).Title
            End If
        Next i
        Do While oCCTitle = ""
        'Loop to ensure that each CC created will have a title if none exists
            oCCTitleAssignment = InputBox("You Must Enter the Title for the Content Controls to be added", "Enter Title", "")
            If oCCTitleAssignment = "" Then
                oCancelOperation = MsgBox("You didn't enter a title for this Content Control, do you want to cancel the operation?", vbYesNo, "error")
                If oCancelOperation = vbYes Then
                    Exit Sub
                End If
                'Make sure that the title isn't already taken by a different CC
                For i = 1 To ActiveDocument.ContentControls.Count
                    If ActiveDocument.ContentControls(i).Title = oCCTitle And ActiveDocument.ContentControls(i).Range.Text <> oQuery Then
                        oSameTitle = True
                    End If
                Next i
                If oSameTitle = True Then
                    MsgBox ("This Title is already used for another Content Control, Please Choose Another")
                End If
            End If
        Loop
        'Then map the CC to the customXMLpart and assign the title to the CC
        If Not oRng.InRange(ActiveDocument.SelectContentControlsByTitle(oCCTitle).Item(1).Range) Then
 ***  Set oCC = ActiveDocument.ContentControls.Add(wdContentControlText, oRng)   ******
        oCC.XMLMapping.SetMapping (ActiveDocument.SelectContentControlsByTitle(oCCTitle).Item(1).XMLMapping.xPath)
        oCC.Title = oCCTitle
        oRng.Collapse wdCollapseEnd
        End If
    Wend
  End With
End Sub