Sub Demo()
Application.ScreenUpdating = False
ActiveWindow.View.ShowFieldCodes = True
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Section ^d"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    With .Fields(1)
      With .Code
        If InStr(.Text, "Mergeformat") > 0 Then
          .Text = Replace(.Text, "Mergeformat", "Charformat")
        ElseIf InStr(.Text, "Charformat") = 0 Then
          .InsertAfter " \* Charformat"
        End If
        .Words.First.Next.Style = "Emphasis"
      End With
      .Update
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
ActiveWindow.View.ShowFieldCodes = False
Application.ScreenUpdating = True
End Sub