CODEWITHSUNDEEP
vbams-word
plaene
plaene

Reputation: 61

Search specific selection of Word document in VBA

I have a macro to search for certain keywords in Word files. The procedure is to:

The problem I am facing now is that the find function triggers on the copied text on the first page. I tried to define the search area from the second page onward:

Sub HighlightWords()

Dim DocRange As word.Range
PageCount = ActiveDocument.ComputeStatistics(wdStatisticPages)
ActiveDocument.Select
Set DocRange = Selection.Range
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2
DocRange.Start = Selection.Bookmarks("\Page").Range.Start
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=PageCount
DocRange.End = Selection.Bookmarks("\Page").Range.End
Application.ScreenUpdating = False

Options.DefaultHighlightColorIndex = wdYellow
With DocRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.text = keyword
.Replacement.text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
If DocRange.Find.Found = True Then
ActiveDocument.GoTo(What:=wdGoToLine, Count:=2).Select
Selection.Style = ActiveDocument.Styles("Normal")
Selection.InsertBreak Type:= wdLineBreak
Selection.InsertAfter text:= keyword & "found in " & file.Name
ElseIf DocRange.Find.Found = False Then
End If
End Sub

However the code still finds the keyword on the first page which should not happen. How can I solve this issue?

Upvotes: 0

Views: 2415

Answers (2)

macropod
macropod

Reputation: 13515

You might try something along the lines of:

Sub KeyWordFinder()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, i As Long
Dim DocSrc As Document, DocTgt As Document, StrFnd As String, StrOut As String
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set DocTgt = ThisDocument: strDocNm = DocTgt.FullName
StrFnd = "|": Options.DefaultHighlightColorIndex = wdYellow
With DocTgt.Tables(1)
  For i = 2 To .Rows.Count
    StrFnd = StrFnd & Split(.Rows(i).Cells(1).Range.Text, vbCr)(0) & "|"
  Next
End With
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With DocSrc
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Text = "^&"
        .Replacement.Highlight = True
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
        'Process each word from the StrFnd List
        For i = 1 To UBound(Split(StrFnd, "|"))
          .Text = Split(StrFnd, "|")(i)
          .Execute Replace:=wdReplaceAll
          If .Found = True Then
            StrOut = StrOut & Split(StrFnd, "|")(i) & " found in " & strFile & Chr(11)
          End If
        Next
      End With
      .Close True
    End With
  End If
  DoEvents
  strFile = Dir()
Wend
DocTgt.Range.InsertAfter StrOut
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

As coded, the macro assumes the output is to be sent to the document it's being run from and that the keyword list is in the first column of the first table in that document, starting at row 2. The code includes a folder browser, so all you need do is select the folder to process. I've retained your highlighting specs, though I can't see the point of having them, as your code deletes the found content from the files before deleting the files anyway. My implementation highlights the found content in the source files. If you don't want to do that, you may as well delete:

: Options.DefaultHighlightColorIndex = wdYellow

.Replacement.Highlight = True

.Replacement.Text = "^&"

and

Replace:=wdReplaceAll

as well as changing:

.Close True

to:

.Close False

Whichever way you approach it, the above code should be much more efficient than what you're now using.

Upvotes: 1

macropod
macropod

Reputation: 13515

See my comments on your approach. As for the problem itself, change:

.Wrap = wdFindContinue

to:

.Wrap = wdFindStop

PS: Even with your present approach, all of:

PageCount = ActiveDocument.ComputeStatistics(wdStatisticPages)
ActiveDocument.Select
Set DocRange = Selection.Range
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2
DocRange.Start = Selection.Bookmarks("\Page").Range.Start
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=PageCount
DocRange.End = Selection.Bookmarks("\Page").Range.End

could be replaced with:

Set DocRange = ActiveDocument.Range(0, 0)
Set DocRange = DocRange.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2)
Set DocRange = DocRange.GoTo(What:=wdGoToBookmark, Name:="\page")
DocRange.End = ActiveDocument.Range.End

Upvotes: 0

Related Questions