Sub ApplyCharacterStyles()
  Application.ScreenUpdating = False
  Dim Rng As Range, i As Long, j As Long, ArrStyl, ArrItal, ArrBold, ArrUlin, bFnd As Boolean, aSty As Style
  ArrStyl = Array("Bold", "Italic", "Underline", "Bold Italic", "Bold Underline", "Italic Underline", "Bold Italic Underline")

  With ActiveDocument
    On Error Resume Next
      For i = 0 To UBound(ArrStyl)
        Set aSty = .Styles(ArrStyl(i))
        If aSty Is Nothing Then
          Set aSty = .Styles.Add(Name:=ArrStyl(i), Type:=wdStyleTypeCharacter)
        End If
        With aSty.Font
          .Italic = aSty.NameLocal Like "*Italic*"
          .Bold = aSty.NameLocal Like "*Bold*"
          .Underline = aSty.NameLocal Like "*Underline*"
        End With
        Set aSty = Nothing
      Next
    On Error GoTo 0

    For Each Rng In .StoryRanges
      For i = UBound(ArrStyl) To 0 Step -1
        Set aSty = ActiveDocument.Styles(ArrStyl(i))
        With Rng.Duplicate
          With .Find
            With .Font
              .Italic = aSty.Font.Italic
              .Bold = aSty.Font.Bold
              .Underline = aSty.Font.Underline
            End With
          End With
          Do While .Find.Execute = True
            If .Style <> aSty 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 <> aSty.Font.Italic Then
                    If .Bold <> aSty.Font.Bold Then
                      If .Underline <> aSty.Font.Underline Then .Style = aSty
                    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