Option Explicit
Sub CleanText()
Application.ScreenUpdating = False
'2 dashes to en-dash
Application.StatusBar = "Replacing 2 dashs with en dash"
Call StrReplace("--", "^0150", , , False)
'4 dots with ellipsis+period
Application.StatusBar = "Replacing 4 dots with ellipsis and period"
Call StrReplace("([a-z])(....)", "\1^0133.", , , True)
Call StrReplace("([a-z])(. . . .)", "\1^0133.", , , True)
Call StrReplace("([a-z] )(....)", "\1^0133.", , , True)
Call StrReplace("([a-z] )(. . . .)", "\1^0133.", , , True)
'3 dots with ellipsis
Application.StatusBar = "Replacing 3 dots with ellipsis"
Call StrReplace("...", "^0133", , , False)
Call StrReplace(" ...", "^0133", , , False)
Call StrReplace(". . .", "^0133", , , False)
Call StrReplace(" . . .", "^0133", , , False)
'replace hyphen with en-dash sometimes
Application.StatusBar = "Replacing hyphen with en dash, as required"
Call StrReplace("([a-z])(-)([A-Z])", "\1^=\3", , , True)
Call StrReplace("([0-9])(-)([0-9])", "\1^=\3", , , True)
Call StrReplace("-^p", "-", , , False)
'space before and after em-dash and en-dash
Application.StatusBar = "Replacing spaces after em and en dash"
Call StrReplace("([!0-9])(^0150)([!0-9])", "\1 \2 \3", , , True)
Call StrReplace("([!0-9])(^0151)([!0-9])", "\1 \2 \3", , , True)
'add a space after ,;: followed by lower case letter if needed
Call StrReplace("([,;:])([a-z])", "\1 \2", , , True)
Application.StatusBar = "Replacing space+tab with single tab"
Call StrReplace(" {1,}^t", "^t", , , True)
Application.StatusBar = "Replacing tab+spaces with single tab"
Call StrReplace("^t {1,}", "^t", , , True)
Application.StatusBar = "Replacing tab+paragraph with single paragraph mark"
Call StrReplace("^t{1,}^13", "^p", , , True)
Application.StatusBar = "Replacing multiple spaces with single space"
Call StrReplace(" {2,}", " ", , , True)
Application.StatusBar = "Replacing paragraph+space with single paragraph mark"
Call StrReplace("^13 {1,}", "^p", , , True)
Application.StatusBar = "Replacing space+paragraph with single paragraph mark"
Call StrReplace(" {1,}^13", "^p", , , True)
Application.StatusBar = "Replacing multiple paragraph marks with single paragraph mark"
Call StrReplace("^13{2,}", "^p", , , True)
Application.StatusBar = "Replacing LC+paragraph marks+LC with space"
Call StrReplace("([a-z,0-9])(^13)([a-z,0-9])", "\1 \3", , , True)
Application.StatusBar = "Replacing puncation + paragraph mark + LC with space"
Call StrReplace("([-;:,.])(^13)([a-z,0-9])", "\1 \3", , , True)
End Sub
'http://www.vbaexpress.com/forum/showthread.php?49287-Replacing-text-in-all-sections-headers-and-footers
Sub StrReplace(OldStr As String, NewStr As String, _
Optional WholeWord = False, _
Optional MatchCase = False, _
Optional WildCard = False)
Dim oStoryRange As Range, oSection As Section, oHeaderFooter As HeaderFooter
With ActiveDocument
For Each oStoryRange In .StoryRanges
Select Case oStoryRange.StoryType
Case wdPrimaryFooterStory, _
wdFirstPageFooterStory, _
wdEvenPagesFooterStory, _
wdPrimaryHeaderStory, _
wdFirstPageHeaderStory, _
wdEvenPagesHeaderStory
Case Else
Call pvtFR(oStoryRange, OldStr, NewStr, WholeWord, MatchCase, WildCard)
End Select
Next
For Each oSection In .Sections
For Each oHeaderFooter In oSection.Headers
With oHeaderFooter
If Not .LinkToPrevious Then Call pvtFR(.Range, OldStr, NewStr, WholeWord, MatchCase, WildCard)
End With
Next
For Each oHeaderFooter In oSection.Footers
With oHeaderFooter
If Not .LinkToPrevious Then Call pvtFR(.Range, OldStr, NewStr, WholeWord, MatchCase, WildCard)
End With
Next
Next
End With
End Sub
Private Sub pvtFR(s As Range, StringToFind As String, StringForReplace As String, _
Optional WholeWord = False, Optional MatchCase = False, Optional WildCard = False)
With s.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindContinue
.Text = StringToFind
.Replacement.Text = StringForReplace
.MatchCase = MatchCase
.MatchAllWordForms = False
.MatchWholeWord = WholeWord
.MatchWildcards = WildCard
.Execute Replace:=wdReplaceAll
End With
End Sub
'call a routine that removes all settings from the find dialog
'so future users of the dialog won't get strange results
Sub ClearFindAndReplaceParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub