Sub MapAColectionOfCustomXMLParts()
Dim oCCs As New Collection
Dim oCXPart As CustomXMLPart
Dim oCC As ContentControl
Dim lngIndex As Long
Dim strTitle As String
  'Create a fresh CustomXMLPart for mapping.
  On Error Resume Next
  'Kill any existing CustomXMLPart used previously.
  Set oCXPart = ActiveDocument.CustomXMLParts.SelectByNamespace _
               ("http//mapCCcollection@namespace.com").Item(1)
  If Err.Number = 0 Then
    oCXPart.Delete
  End If
  On Error GoTo 0
  'Create the new CustomXMLPart.
  ActiveDocument.CustomXMLParts.Add _
                ("<CC_Collection xmlns='http//mapCCCollection@namespace.com'/>")
  Set oCXPart = ActiveDocument.CustomXMLParts.SelectByNamespace _
                ("http//mapCCCollection@namespace.com").Item(1)
 
  'Get unique titles.
  For Each oCC In ActiveDocument.ContentControls
    If oCC.Title <> "" Then
      On Error Resume Next
      oCCs.Add oCC, oCC.Title
    End If
  Next oCC
  On Error GoTo 0
 
  For lngIndex = 1 To oCCs.Count
    'Add a CustomXMLNode for eacj uniqued titled CC.
     Set oCC = oCCs(lngIndex)
     strTitle = Replace(oCC.Title, " ", "_")
     oCXPart.AddNode oCXPart.SelectSingleNode("ns0:CC_Collection"), _
                            strTitle, , , msoCustomXMLNodeElement
  Next lngIndex
  'Map titled CCs.
  For Each oCC In ActiveDocument.ContentControls
    If oCC.Title <> "" Then
      oCC.XMLMapping.SetMappingByNode oCXPart.SelectSingleNode("//" & Replace(oCC.Title, " ", "_") & "[1]")
    End If
  Next oCC
lbl_Exit:
  Exit Sub
End Sub