I found the solution.

Sub boltitalic()

Dim objDoc As Document
Dim cboltitalic As Style
Set objDoc = ActiveDocument

Set cboltitalic = ActiveDocument.Styles.Add("*boltitalic", Type:=WdStyleType.wdStyleTypeCharacter)
With cboltitalic.Font
.Name = "Times New Roman"
.Bold = True
.Italic = True
.Subscript = False
.Superscript = False

End With

Dim rngStory As Range
For Each rngStory In ActiveDocument.StoryRanges

Application.ScreenUpdating = False
With ActiveDocument.Range
With rngStory.Find

Options.DefaultHighlightColorIndex = wdYellow
.ClearFormatting
.Replacement.ClearFormatting
.text = ""
.Replacement.text = ""
.MatchWildcards = True
.Format = True
.Forward = True
.Wrap = wdFindContinue

.Font.Bold = True
.Font.Italic = True
.Font.Subscript = False
.Font.Superscript = False
.Replacement.Style = "*boltitalic"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll


End With
End With
Next rngStory
Application.ScreenUpdating = True
End Sub