Sub Macro1()
    Selection.HomeKey wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "***"
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
End Sub

Sub Macro2()
Dim oRng As Range
Dim oCC As ContentControl
Dim i As Integer: i = 0
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Wrap = wdFindContinue
        Do While .Execute("***")
            i = i + 1
            oRng.Text = ""
            Set oCC = oRng.ContentControls.Add(wdContentControlRichText)
            oCC.Title = "Text" & i
            oCC.Tag = oCC.Title
            oCC.LockContentControl = True
            oRng.End = oRng.End + 1
            oRng.Collapse 0
        Loop
    End With
End Sub