Delete every word with all or partial underline

[Joe]

I can't figure out the format for a sub to delete every word that has some underlining in it. I can't figure it out because I need to find each underline and then delete the whole word containing it.
Here's my lame code so far I pieced together reading the forum:

Sub DeleteUnderline()
'
' DeleteUnderline Macro
'

Dim oRng As Word.Range
Set oRng = ActiveDocument.Range

With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.Underline = wdUnderlineSingle
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWildcards = True
.MatchWholeWord = False
.MatchSoundsLike = False
.MatchAllWordForms = False
While .Execute
oRng.Words(1).Delete
Wend
End With
End Sub


Submitted via EggHeadCafe - Software Developer Portal of Choice
Updated: Production Exception Handling For Dummies 101
http://www.eggheadcafe.com/tutorial...5c-a3f5b2184aa5/updated-production-excep.aspx

 

[Klaus Linke]

Hi Joe,

The code looks fine, and reasonably fast ... Does it work?

Regards,
Klaus

 

[Joe]

Hi Joe,

The code looks fine, and reasonably fast ... Does it work?

Regards,
Klaus

No, it's amazingly slow, and it's not working right. I can not figure
out what it's doing. Sorry I wasn't clear enough earlier. Something is
not right with it.

 

[Joe]

Ok, I finally got some code to work. Final tweak that should be made
is to change it to work on a range instead of selection so don't have
to toggle screen updating, but not sure how to do that. The code is
easily adapted to find any substring of a word and then delete that
whole word.


Sub DeleteUnderline()
'
'
Application.ScreenUpdating = False
Do Until ActiveDocument.Bookmarks("\Sel") = ActiveDocument.Bookmarks
("\EndOfDoc")
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdStop
.Font.Underline = wdUnderlineSingle
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

If Selection.Find.Found = True Then
Selection.Words(1).Select
Selection.Delete Unit:=wdWord, Count:=1
Else
Exit Do
End If
Loop
Application.ScreenUpdating = True
End Sub

 

[macropod]

Hi Joe,

Somewhat more efficiently:
Sub DeleteUnderline()
Application.ScreenUpdating = False
With Selection.Find
.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Font.Underline = wdUnderlineSingle
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Do While .Found = True
Selection.Words(1).Delete
.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub

 

[Fumei2 via OfficeKB.com]

And perhaps a little more efficiently. No need to fiddle with ScreenUpdating.


Sub DeleteUnderline()
Dim r As Range
Set r = ActiveDocument.Range
With r.Find
.ClearFormatting
.Text = ""
.Font.Underline = wdUnderlineSingle
Do While .Execute = True
r.Expand Unit:=wdWord
r.Delete
Loop
End With
End Sub

Hi Joe,

Somewhat more efficiently:
Sub DeleteUnderline()
Application.ScreenUpdating = False
With Selection.Find
.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Font.Underline = wdUnderlineSingle
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Do While .Found = True
Selection.Words(1).Delete
.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub

Ok, I finally got some code to work. Final tweak that should be made
is to change it to work on a range instead of selection so don't have

[quoted text clipped - 33 lines]

Application.ScreenUpdating = True
End Sub