VBA найти текстовые документы и указанные слова в содержании, а затем перечислить в Excel

Question

У меня в папке есть документы из нескольких слов.
Что я действительно хочу, так это перечислить названия документов и проверить, содержат ли эти документы некоторые указанные слова.

Я создаю два документа на слово, например, для объяснения.
В папке есть два документа, Doc A и Doc B.

1. Я хочу перечислить имена файлов Doc A и Doc B в столбце Excel A.
2. После перечисления имени документа в столбце AЯ хочу проверить, есть ли в документах указанные слова «классификация» и «статистика».
3. Если указанные слова в документе, он будет отмечен в Excel.Пожалуйста, см. Рисунок ниже для результата, который я хочу.
   

Я предоставляю код в следующем:

Option Explicit
Private xRow As Long

Sub Get_MAIN_File_Names()
    Dim fso As FileSystemObject
    Dim xDirect As String
    Dim xRootFolder As Folder
    Dim DrawingNumb As String
    Dim RevNumb As String
    Dim rootFolderStr As String

    Set fso = New FileSystemObject
    xRow = 0
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = "Select Main File"
       .Show
       'PROCESS ROOT FOLDER
       If .SelectedItems.Count <> 0 Then
          xDirect = .SelectedItems(1) & "\"
          Set xRootFolder = fso.GetFolder(xDirect)
          ProcessFolder fso, xRootFolder
       End If
    End With
End Sub

Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
    Dim xFiles As Files
    Dim xFile As File
    Dim xSubFolders As Folders
    Dim xSubFolder As Folder
    Dim xFileName As String
    Dim objWordApplication As New Word.Application
    Dim objWordDocument As Word.Document
    Dim strFile As String

    strFile = Dir(xFolder & "*.doc", vbNormal)
    While strFile <> ""
     With objWordApplication
       Set objWordDocument = .Documents.Open(FileName:=xFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)

    Set xFiles = xFolder.Files
    'Adding Column names
    Cells(1, "A").Value = "Document Name"
    Cells(1, "B").Value = "classification"
    Cells(1, "C").Value = "Statistics"    
    'LOOPS THROUGH EACH FILE NAME IN FOLDER
    For Each xFile In xFiles

      'EXTRACT INFORMATION FROM FILE NAME, this part may not add
       xFileName = xFile.Name

       Set Docs = objWordDocument.Content   
        With Docs.Find  
         .ClearFormatting
         .Text = "classification"
         Wrap:=wdFindContinue
        End With

        With Docs.Find  
         .ClearFormatting
         .Text = "Statistics"
         Wrap:=wdFindContinue
        End With

      'INSERT INFO INTO EXCEL
       ActiveCell.Offset(xRow, 0) = xFileName

      'Below needs to add.
       ActiveCell.Offset(xRow, 1) = 
       ActiveCell.Offset(xRow, 2) = 
      'Above needs to add.

       xRow = xRow + 1
      With objWordDocument
       .Close

  End With
    Next xFile
    Set xSubFolders = xFolder.SubFolders
    For Each xSubFolder In xSubFolders
        ProcessFolder fso, xSubFolder
    Next xSubFolder
End Sub

На основеПриведенный выше код не работает.
Я думаю, что проблема With Docs.Find.....;однако я не совсем уверен в этом.
Более того, я не знаю, как сделать эту часть.

      'Below needs to add.
       ActiveCell.Offset(xRow, 1) = 
       ActiveCell.Offset(xRow, 2) = 
      'Above needs to add.

Может ли кто-нибудь помочь мне отредактировать код?

Answer 1

Может быть, этот код поможет вам, он делает:

• Предположим, вы получили настройку ActiveSheet с тремя там заголовками
• Цикл .docx файлов в указанной папке
• Проверяет диапазон слов для указанного текста

• Возвращает true или false и помещает найденный или не найденный в соответствующую ячейку

  Sub LoopWordDocs()
  
  Dim FLDR As String
  Dim wDoc As Word.Document
  Dim wRNG As Word.Range
  Dim LR As Long, COL As Long
  Dim WS As String
  Dim wAPP As Word.Application
  Dim WordWasNotRunning As Boolean
  
  On Error Resume Next
  Set wAPP = GetObject(, "Word.Application")
  If Err Then
      Set wAPP = New Word.Application
      WordWasNotRunning = True
  End If
  On Error GoTo Err_Handler
  
  WS = ThisWorkbook.ActiveSheet.Name
  FLDR = "U:\Test\" 'Change directory accordingly
  aDoc = Dir(FLDR & "*.docx") 'Change docx to .doc if you need
  Do While aDoc <> ""
      Set wDoc = Documents.Open(Filename:=FLDR & aDoc)
      LR = Sheets(WS).Cells(Rows.Count, "A").End(xlUp).Row + 1
      Sheets(WS).Cells(LR, 1) = aDoc
      Set wRNG = wDoc.Range
      For COL = 2 To 3 'It will loop through B1 and C1 to check if present in text
          With wRNG.Find
              .Text = Sheets(WS).Cells(1, COL).Text
              .MatchCase = False
              .MatchWholeWord = True
              If wRNG.Find.Execute = True Then
                  Sheets(WS).Cells(LR, COL) = "V" 'Change V to your liking
              Else
                  Sheets(WS).Cells(LR, COL) = "X" 'Change X to your liking
              End If
          End With
      Next COL
      wDoc.Close SaveChanges:=True
      aDoc = Dir
  Loop
  Exit Sub
  
  Err_Handler:
  MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
  If WordWasNotRunning Then
      wAPP.Quit
  End If
  
  End Sub
  

Примечание: вам нужно будет включить библиотеку объектов Microsoft Word 14.0, чтобы это работало