I found this macro. It does more than what you are looking for, so you probably should strip out the "extra stuff".
<snip>
EmailClean Macro
I posted the following macro a long time ago.
It will reformat selected text by changing a paragraph mark into a space, changing 2 or more paragraphs to 1, changing 2 or more line breaks to 1, & putting 2 spaces between all sentences.
It also removes white space at the beginning & end (& middle) of each sentence. You can modify it to put only one space betweeen sentences.
Anything that starts with a ' is a comment & you can delete it, if you want.
Note: Do not use the macro on other macros (as it gets rid of the paragraph marks).
Just copy & paste the macro into a global template. I've placed it on a menu so that I can call it just by typing Alt, M, E.
Sub EmailClean()
'
' EmailClean Macro
' operates on selected text
' Macro created 6/12/01 by Phil Rabichow
'
Application.ScreenUpdating = False
Selection.Range.Style = ActiveDocument.Styles(wdStyleNormal)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
' Replace line break with paragraph mark
With Selection.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Remove white space at the beginning of lines
With Selection.Find
.Text = "^p^w"
.Replacement.Text = "^p"
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Remove spaces before paragraph marks
With Selection.Find
.Text = " {1,}^013"
.Replacement.Text = "^p"
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
' This prevents extra paragraph marks at the end of the selection
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
' Removes spaces in first line
With Selection.Find
.Text = " {3,}"
.Replacement.Text = ""
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Replace end of line paragraph marks with a space
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "%$%"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Since this causes 3 paragraph marks to have a space,
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "%$%"
.Replacement.Text = "^p"
End With
Selection.Find.Execute Replace:=wdReplaceAll
' we added this to remove the space paragraph
With Selection.Find
.Text = "^p "
.Replacement.Text = "^p"
End With
Selection.Find.Execute Replace:=wdReplaceAll
' This puts 2 spaces between sentences
With Selection.Find
.Text = ". {1,}"
.Replacement.Text = ".
"
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "? {1,}"
.Replacement.Text = "?
"
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "! {1,}"
.Replacement.Text = "!
"
End With
Selection.Find.Execute Replace:=wdReplaceAll
' we'll see how it works without this
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
' With Selection.Find
' .Text = "^w^p"
' .Replacement.Text = "^p"
' .MatchWildcards = False
' End With
'Selection.Find.Execute Replace:=wdReplaceAll
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = "^p^p"
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' With Selection.Find
' .Text = " {1,}^013"
' .Replacement.Text = "^p"
' .MatchWildcards = True
' End With
'Selection.Find.Execute Replace:=wdReplaceAll
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
Application.ScreenUpdating = True
End Sub
</snip>