Macro for global searching

[Fonsi]

Hi guys,

I usually have to review huge documents where I need to indentify certain issues.

For this reason, I need a code which allow me to search for layout errors through the whole document without taking any action. They will be fixed later on.

For example, if I want to find double spaces in a Word file, what is
the code to do a global search?

I assume that the macro will do a pause every time it finds a double space but this is exactly what I am looking for.

Frankly speaking, I don´t know the VBA code which does global searchs in a document, so I would appreciate your help on this!

Hopefully, I will be able to recycle this code for any other global searchs that I need to do in a daily basis.

Cheers!

[gmayor]

You don't need a macro to search for double spaces. The replace function in Word (CTRL+H) will do what you want - see http://www.gmayor.com/replace_using_wildcards.htm and stop at each occurrence as required.

If you want to perform a selection of searches, see http://www.gmayor.com/document_batch_processes.htm (http://www.gmayor.com/document_batch_processes.htm)

[Paul_Hossler]

FWIW, I put this together years ago

StrReplace () is a sub that wraps the Word F&R function to go through all parts of the document (sections, headers, footers, etc.)

It might have been superseded by some new Word functionality, but I've never got around to testing

CleanText() is the upper level sub that calls StrReplace that I use to fix common errors in a document to personal preferences.

I'm not sure why you just want to identify errors and fix them late, since even in the simplest case like Graham says, you can replace " " with one " ". As an aside, you'd need to do multiple times if you had many spaces in a group until they were all replaced, unless you used wildcards





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

[gmaxey]

Paul,

Almost ;-). Your code misses the text frame of any shapes anchored to a header or footer. Can be fixed with:


Sub StrReplace(OldStr As String, NewStr As String, _
Optional WholeWord = False, _
Optional MatchCase = False, _
Optional WildCard = False)
Dim oShp As Shape
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)
For Each oShp In oHeaderFooter.Shapes
Call pvtFR(oShp.TextFrame.TextRange, OldStr, NewStr, WholeWord, MatchCase, WildCard)
Next oShp
End If
End With
Next
For Each oHeaderFooter In oSection.Footers
With oHeaderFooter
If Not .LinkToPrevious Then Call pvtFR(.Range, OldStr, NewStr, WholeWord, MatchCase, WildCard)
For Each oShp In oHeaderFooter.Shapes
Call pvtFR(oShp.TextFrame.TextRange, OldStr, NewStr, WholeWord, MatchCase, WildCard)
Next oShp
End With
Next
Next
End With
End Sub