Consulting

Results 1 to 4 of 4

Thread: Macro for global searching

  1. #1
    VBAX Newbie
    Joined
    May 2018
    Posts
    5
    Location

    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!


  2. #2
    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
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    5,867
    Location
    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
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    2,838
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •