Macro for global searching

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!

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

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

Code:

---

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

---

Paul,

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

Code:

---

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

---