Sub ApplyCharacterStyles()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, j As Long, ArrStyl, ArrItal, ArrBold, ArrUlin, bFnd As Boolean
ArrStyl = Array("Bold", "Italic", "Underline", "Bold Italic", "Bold Underline", "Italic Underline", "Bold Italic Underline")
ArrBold = Array(True, False, False, True, True, False, True)
ArrItal = Array(False, True, False, True, False, True, True)
ArrUlin = Array(False, False, True, False, True, True, True)
With ActiveDocument
  For i = 0 To UBound(ArrStyl)
    For j = 1 To .Styles.Count
      bFnd = (ArrStyl(i) = .Styles(j)): If bFnd = True Then Exit For
    Next
    If bFnd = False Then .Styles.Add Name:=ArrStyl(i), Type:=wdStyleTypeCharacter
  Next
  For i = 0 To UBound(ArrStyl)
    With .Styles(ArrStyl(i)).Font
      .Italic = ArrItal(i)
      .Bold = ArrBold(i)
      .Underline = ArrUlin(i)
    End With
  Next
  For Each Rng In .StoryRanges
    For i = UBound(ArrStyl) To 0 Step -1
      With Rng.Duplicate
        With .Find
          With .Font
            .Italic = ArrItal(i)
            .Bold = ArrBold(i)
            .Underline = ArrUlin(i)
          End With
        End With
        Do While .Find.Execute = True
          If .Style <> ArrStyl(i) Then
            If .Start <> .Paragraphs.First.Range.Start Or .End <> .Paragraphs.Last.Range.End Then
              .Style = ArrStyl(i)
            Else
              With .Paragraphs.First.Range.Style.Font
                If .Italic <> ArrItal(i) Then
                  If .Bold <> ArrBold(i) Then
                    If .Underline <> ArrUlin(i) Then .Style = ArrStyl(i)
                  End If
                End If
              End With
            End If
          End If
          If .Information(wdWithInTable) = True Then
            If .End = .Cells(1).Range.End - 1 Then .Start = .Cells(1).Range.End
            If .Information(wdAtEndOfRowMarker) = True Then .Start = .End + 1
          End If
          If .End = Rng.End Then Exit Do
          .Collapse wdCollapseEnd
        Loop
      End With
    Next
  Next
End With
Application.ScreenUpdating = True
MsgBox "Finished applying Character Styles"
End Sub

With .Styles(ArrStyl(i)).Font