Поиск конкретного выбора документа Word в VBA - PullRequest
Новая
       24

Поиск конкретного выбора документа Word в VBA

0 голосов
/ 14 мая 2018

У меня есть макрос для поиска определенных ключевых слов в файлах Word.Процедура:

  • вставка документа на вторую страницу и далее
  • поиск документа по различным ключевым словам с помощью цикла
  • , если ключевое слово найдено, скопируйтена первой странице
  • удалить вставленный файл при его полном поиске
  • перейти к следующему документу

Проблема, с которой я сейчас сталкиваюсь, заключается в том, что поискФункция запускает скопированный текст на первой странице.Я пытался определить область поиска начиная со второй страницы: 

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

Однако код все еще находит ключевое слово на первой странице, чего не должно быть.Как я могу решить эту проблему?

Ответы [ 2 ]

0 голосов
/ 15 мая 2018

Вы можете попробовать что-то вроде: 

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

В кодированном виде макрос предполагает, что вывод должен быть отправлен в документ, из которого он запускается, и что список ключевых слов находится в первом столбце.первой таблицы в этом документе, начиная со строки 2. Код включает в себя браузер папок, поэтому все, что вам нужно сделать, это выбрать папку для обработки.Я сохранил ваши спецификации подсветки, хотя не вижу смысла их иметь, так как ваш код удаляет найденное содержимое из файлов, прежде чем удалять файлы в любом случае.Моя реализация выделяет найденный контент в исходных файлах.Если вы не хотите этого делать, вы также можете удалить:

: Options.DefaultHighlightColorIndex = wdYellow

.Replacement.Highlight = True

.Replacement.Text= "^ &"

и

Заменить: = wdReplaceAll

, а также изменить:

. Закрыть True

на:

.Закрыть False

Какой бы подход к нему ни был, приведенный выше код должен быть намного эффективнее, чем тот, который вы сейчас используете.

0 голосов
/ 15 мая 2018

Смотрите мои комментарии о вашем подходе. Что касается самой проблемы, измените:

.Wrap = wdFindContinue

до:

.Wrap = wdFindStop

PS: Даже с вашим нынешним подходом, все: 

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

можно заменить на: 

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
...