Macro to remove underscores, except in email address

[TomDW]

Hi,

I'm trying to replace all underscores in a word document with a single space, except for underscores in email addresses.
Could someone please help?
I've got the following already:

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "_"
.Replacement.Text = " "
.Forward = True


.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll


This will replace all underscores. I don't know how to ignore email addresses...
Thanks in advance!

[macropod]

Are your email addresses formatted as hyperlinks?

[TomDW]

Hi Macropod,

Unfortunately the e-mail addresses are not formatted as hyperlinks.
The Word document is the result of merging fields, and apparently this doesn't automatically format the e-mail addresses...

[gmayor]

In that case maybe

Sub Macro1()
Dim oRng As Range
Dim oWord As Range
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:="_")
            Set oWord = oRng.Duplicate
            If oWord.Words(1).Start <> ActiveDocument.Range.Start Then
                oWord.MoveStartUntil Chr(32), wdBackward
                oWord.MoveEndUntil Chr(32) & Chr(13)
                If InStr(1, oWord.Text, "@") = 0 Then oRng.Text = " "
            End If
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Set oWord = Nothing
    Exit Sub
End Sub

[Guessed]

I would use autoformat to create hyperlinks, then do your search and replace, then restore the email displayed text based on the hyperlinks. The code would look like this...

Sub Macro1()
  Dim aHL As Hyperlink
  With Options
    .AutoFormatApplyHeadings = False
    .AutoFormatApplyLists = False
    .AutoFormatApplyBulletedLists = False
    .AutoFormatApplyOtherParas = False
    .AutoFormatReplaceQuotes = False
    .AutoFormatReplaceSymbols = False
    .AutoFormatReplaceOrdinals = False
    .AutoFormatReplaceFractions = False
    .AutoFormatReplacePlainTextEmphasis = False
    .AutoFormatReplaceHyperlinks = True
    .AutoFormatPreserveStyles = True
    .AutoFormatPlainTextWordMail = True
    .LabelSmartTags = False
  End With
  ActiveDocument.Range.AutoFormat

  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "_"
    .Replacement.Text = " "
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
  End With
  For Each aHL In ActiveDocument.Range.Hyperlinks
    If aHL.Type = msoHyperlinkRange Then
      aHL.TextToDisplay = Replace(aHL.Address, "mailto:", "")
    End If
  Next aHL
End Sub

[macropod]

Originally Posted by TomDW

The Word document is the result of merging fields, and apparently this doesn't automatically format the e-mail addresses...

It can (see the Mailmerge Tips and Tricks 'Sticky' thread - https://www.msofficeforums.com/mail-...ps-tricks.html), but that's another story. Try:

Sub Demo()
Application.ScreenUpdating = False
Dim Hlnk As Hyperlink
With ActiveDocument
  With .Range
    'Activate email addresses as hyperinks
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Format = False
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "<[0-9A-?.\-_]{1,}\@[0-9A-?\-_]{1,}.[a-z]{2,3}>"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      .Hyperlinks.Add Anchor:=.Duplicate, Address:="mailto:" & .Text, TextToDisplay:=.Text
      .Start = .Hyperlinks(1).Range.End
      .Find.Execute
    Loop
    'Replace underscores with spaces
    With .Find
      .Text = "_"
      .Replacement.Text = " "
      .Wrap = wdFindContinue
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
  End With
  'Repair email address underscores
  For Each Hlnk In .Hyperlinks
    With Hlnk
      If InStr(.Address, "mailto:") > 0 Then .TextToDisplay = Split(.Address, "mailto:")(1)
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

[TomDW]

Hi everyone, thanks for the replies.
Gmayor's code seems to do the trick...
If I'm having problems with this solution later on, I can always try the other suggestions.
Thanks!