Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 05 Mar 2020
Dim oSource As Document, oTarget As Document
Dim oRng As Range
Dim oPara As Paragraph
Dim oCC1 As ContentControl, oCC2 As ContentControl
    Set oSource = ActiveDocument
    oSource.Save
    If oSource.Path = "" Then GoTo lbl_Exit
    Set oTarget = Documents.Add(oSource.FullName)
    oTarget.Range.Text = vbCr
    For Each oPara In oSource.Paragraphs
        If oPara.Range.Information(wdWithInTable) = False And Len(oPara.Range) > 1 Then

            Set oRng = oTarget.Range
            oRng.Collapse 0

            Set oCC1 = oTarget.ContentControls.Add(wdContentControlRichText, oRng)
            oCC1.Range.Text = oPara.Range.Text
            oCC1.Range.Font.ColorIndex = wdRed
            oCC1.LockContentControl = True
            oCC1.LockContents = True

            Set oRng = oTarget.Range
            oRng.Collapse 0

            Set oCC2 = oTarget.ContentControls.Add(wdContentControlRichText, oRng)
            oCC2.Range.Text = oPara.Range.Text
            oCC2.Range.Font.ColorIndex = wdBlue
            oCC2.LockContentControl = True
        End If
    Next oPara
    oTarget.Paragraphs(1).Range.Delete
lbl_Exit:
    Set oSource = Nothing
    Set oTarget = Nothing
    Set oRng = Nothing
    Set oPara = Nothing
    Exit Sub
End Sub