Find routine in VBA

[Carjoy]

I want to use VBA to find all the bold text in a document. When found and
still selected, copy the formatting, apply a character style called WHATEVER,
then paste the copy formatting back on top of the same text. Once that is
done, Find the next occurance. I need to do this for Italic, and Underline,
and Plain Text.

I can't use wdReplaceALL because I need the text still selected so I can
apply the character style. I can't seem to get this to work. The macro runs
forever. When I break, all the bolded text is exactly what I want (the
character style + bold) but nothing else. One time I got all but the
italics.

Dim doc As Document
Dim strFilename As String
Dim styFilename As Style
Dim rngToSearch As Range
Dim rngResult As Range
Dim f As Font

Set doc = ActiveDocument

'Capture the document name into a variable
strFilename = Left(doc.Name, Len(doc.Name) - 4)

On Error GoTo ErrorHandler

'Define a character style with no font attributes
Set styFilename = doc.Styles.Add(Name:=strFilename,
Type:=wdStyleTypeCharacter)
With styFilename
With .Font
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
End With
End With

BeginHere:
Set rngToSearch = doc.Range
Set rngResult = rngToSearch.Duplicate

'Make sure there isn't any text currently selected
If Selection.Type <> wdSelectionIP Then
Selection.Collapse _
Direction:=wdCollapseStart
End If


'Look for Bold text
Do
With rngResult.Find
.ClearFormatting
.Format = True
.Font.Bold = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not rngResult.Find.Found Then Exit Do

Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Style = styFilename
.Font = f
.MoveStart wdParagraph
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found

'Look for Italic text
Do
With rngResult.Find
.ClearFormatting
.Format = True
.Font.Italic = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not rngResult.Find.Found Then Exit Do

Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Style = styFilename
.Font = f
.MoveStart wdParagraph
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found

'Look for underline text
Do
With rngResult.Find
.ClearFormatting
.Format = True
.Font.Underline = wdUnderlineSingle
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not rngResult.Find.Found Then Exit Do

Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Style = styFilename
.Font = f
.MoveStart wdWord
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found


'Look for plain text
Do
With rngResult.Find
.ClearFormatting
.Format = True
.Font.Italic = False
.Font.Bold = False
.Font.Underline = wdUnderlineNone
.Forward = True
.Wrap = wdFindStop
.Execute
End With

If Not rngResult.Find.Found Then Exit Do

Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Style = styFilename
.Font = f
.MoveStart wdWord
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found

Else
'If Response = vbNo
MsgBox ("Document will not be changed")
Exit Sub

End If
Application.StatusBar = ""

ErrorHandler:
Select Case Err.Number
'Style name already exists
Case 5173
Set styFilename = doc.Styles(strFilename)
GoTo BeginHere
End Select

End Sub

Thanks!

Caren

 

[Carjoy]

Never mind......

I found a good example in a post from last year.