Word

Search and Report All Occurrences of a Word or Phrase

Ease of Use

Intermediate

Version tested with

2002 / 2000 

Submitted by:

Jacob Hilderbrand

Description:

Searches all documents in designated folder for a designated Word or phrase and reports their location. 

Discussion:

You want to search your documents for a particular word or phrase. Maybe there are several occurances, and you would like them in an easy to view format. This macro provides a new document with a table that itemizes the document name (hyperlink), page number, and line number. 

Code:

instructions for use

			

Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub ListText() Dim Doc As Document Dim NewDoc As Document Dim Search As String Dim Prompt As String Dim Title As String Dim PageX() As Long Dim LineX() As Long Dim FPath() As String Dim FName() As String Dim NewTable As Table Dim Row As Long Dim Counter As Long Dim Pos As Double Dim Path As String Dim FileName As String Dim MyResponse As VbMsgBoxResult Dim StartLine As Long Dim StartPage As Long WordBasic.DisableAutoMacros True '*** Get folder from user *** Prompt = "Select the folder with the files that you want to search through." Title = "Folder Selection" MsgBox Prompt, vbInformation, Title Path = BrowseFolder("Select A Folder") If Path = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title GoTo Canceled: End If '*** This code works with XP only and is also used to pick a folder *** 'Application.FileDialog(msoFileDialogFolderPicker).Show 'Path = CurDir Prompt = "What do you want to search for?" Title = "Search Criteria" Search = InputBox(Prompt, Title) If Search = "" Then GoTo Canceled End If '*** Confirm the procedure before continuing *** Prompt = "Are you sure that you want to search all the files in the folder:" & _ vbCrLf & Path & " for " & """" & Search & """" & "?" Title = "Confirm Procedure" MyResponse = MsgBox(Prompt, vbQuestion + vbYesNo, Title) If MyResponse = vbNo Then GoTo Canceled: End If Application.DisplayAlerts = False Application.ScreenUpdating = False '*** Loop through all Word documents and search each of them for the specified criteria*** FileName = Dir(Path & "\*.doc", vbNormal) Do Until FileName = "" On Error Resume Next Documents.Open Path & "\" & FileName, ReadOnly:=True, PasswordDocument:="DRJWasHere" If Err <> 0 Then GoTo NextLoop: End If On Error GoTo 0 Set Doc = ActiveDocument Selection.HomeKey Unit:=wdLine Selection.MoveUp Unit:=wdLine, Count:=99999 With Doc Selection.Find.ClearFormatting With Selection.Find .Text = Search .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute If Selection.Range.Text <> Search Then GoTo NextLoop: End If Pos = Selection.Range.Information(wdHorizontalPositionRelativeToPage) Counter = Counter + 1 ReDim Preserve LineX(1 To Counter) ReDim Preserve PageX(1 To Counter) ReDim Preserve FPath(1 To Counter) ReDim Preserve FName(1 To Counter) LineX(Counter) = Selection.Range.Information(wdFirstCharacterLineNumber) PageX(Counter) = Selection.Range.Information(wdActiveEndPageNumber) FPath(Counter) = Doc.Path FName(Counter) = Doc.Name StartLine = Selection.Range.Information(wdFirstCharacterLineNumber) StartPage = Selection.Range.Information(wdActiveEndPageNumber) Selection.Find.Execute Do While Pos <> Selection.Range.Information(wdHorizontalPositionRelativeToPage) Or _ StartLine <> Selection.Range.Information(wdFirstCharacterLineNumber) Or _ StartPage <> Selection.Range.Information(wdActiveEndPageNumber) Counter = Counter + 1 ReDim Preserve LineX(1 To Counter) ReDim Preserve PageX(1 To Counter) ReDim Preserve FPath(1 To Counter) ReDim Preserve FName(1 To Counter) If LineX(Counter - 1) = Selection.Range.Information(wdFirstCharacterLineNumber) And _ PageX(Counter - 1) = Selection.Range.Information(wdActiveEndPageNumber) And _ Pos = Selection.Range.Information(wdHorizontalPositionRelativeToPage) Then Exit Do Else LineX(Counter) = Selection.Range.Information(wdFirstCharacterLineNumber) PageX(Counter) = Selection.Range.Information(wdActiveEndPageNumber) FPath(Counter) = Doc.Path FName(Counter) = Doc.Name Pos = Selection.Range.Information(wdHorizontalPositionRelativeToPage) Selection.Find.Execute End If Loop NextLoop: End With Doc.Close Set Doc = Nothing On Error GoTo 0 FileName = Dir() Loop If Counter = 0 Then MsgBox Search & " was not found.", vbInformation, "Zero Results For Search" GoTo Canceled: End If Set NewDoc = Documents.Add NewDoc.Select Selection.Range.Text = "Occurrences of the word " & """" & Search & """" Selection.Range.Paragraphs.Alignment = wdAlignParagraphCenter Selection.Range.Font.Bold = True Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.TypeParagraph Selection.TypeParagraph Set NewTable = Selection.Tables.Add(Selection.Range, Counter + 1, 3) NewTable.Range.Font.Bold = False Row = 1 NewTable.Cell(Row, 1).Range.Text = "Document Path" NewTable.Cell(Row, 2).Range.Text = "Page Number" NewTable.Cell(Row, 3).Range.Text = "Line Number" NewTable.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter NewTable.Rows(1).Range.Font.Bold = True NewTable.Rows(1).HeadingFormat = True For Row = UBound(LineX) To 1 Step -1 If PageX(Row) = 0 Or LineX(Row) = 0 Then NewTable.Rows(Row + 1).Delete Else NewTable.Cell(Row + 1, 2).Range.Text = PageX(Row) NewTable.Cell(Row + 1, 3).Range.Text = LineX(Row) NewTable.Cell(Row + 1, 1).Select Selection.MoveLeft Unit:=wdCharacter, Count:=1 ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=FPath(Row) & "\" & FName(Row), _ TextToDisplay:=FName(Row) End If Next Row NewTable.Columns(3).AutoFit NewTable.Columns(2).AutoFit NewTable.Columns(1).AutoFit NewTable.PreferredWidthType = wdPreferredWidthPercent NewTable.PreferredWidth = 100 Canceled: Set Doc = Nothing Set NewTable = Nothing Set NewDoc = Nothing WordBasic.DisableAutoMacros False Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

How to use:

  1. Copy the code above.
  2. Open Word.
  3. Alt + F11 to open the Visual Basic Editor.
  4. On the left, choose Normal (or normal.dot).
  5. Hit Insert-Module from the menu.
  6. Paste the code into the window that appears at right.
  7. Close the VBE (Alt + Q or press the x in the top right corner).
 

Test the code:

  1. Hit Tools-Macro-Macros and double-click ListText.
  2. Input the search word and press Ok.
 

Sample File:

WordSearcher.ZIP 19.27KB 

Approved by mdmackillop


This entry has been viewed 356 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express