Sub Demo()
Application.ScreenUpdating = False
Dim RngFnd As Range, RngTmp As Range, StrTxt(), StrTmp1 As String, StrTmp2 As String
StrTxt() = Array("MYTEXT1 ", "MYTEXT2 ", "MYTEXT3", "MYTEXT4")
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13][0-9]{1,}.[!^13]{1,}"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    If .Font.Bold = 9999999 Or .Font.Italic = 9999999 Then
      .Start = .Start + 1
      .InsertBefore StrTxt(0)
      .Start = .Start + Len(StrTxt(0))
      .Start = .Start + InStr(.Text, ". ") + 1
      Set RngFnd = .Duplicate: Set RngTmp = .Duplicate
      StrTmp1 = "": StrTmp2 = ""
      RngTmp.Collapse wdCollapseStart
      With .Duplicate
        With .Find
          .ClearFormatting
          .Format = True
          .Font.Bold = False
          .Font.Italic = False
          .Wrap = wdFindStop
          .Execute
        End With
        Do While .Find.Found
          If Not .InRange(RngFnd) Then
            RngTmp.End = RngFnd.End
            With RngTmp
              If .Font.Bold = True Or .Font.Italic = True Then StrTmp2 = StrTmp2 & Trim(.Text) & " "
            End With
            Exit Do
          End If
          StrTmp1 = StrTmp1 & Trim(.Text) & " "
          If .Duplicate.Start > RngTmp.End Then RngTmp.End = .Duplicate.Start
          StrTmp2 = StrTmp2 & Trim(RngTmp.Text) & " "
          RngTmp.Start = .Duplicate.End
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
      End With
      .Text = StrTxt(1) & StrTmp1 & StrTxt(2) & StrTmp2 & StrTxt(3)
      .Font.Bold = False
      .Font.Italic = False
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub