Question

我在一个文件夹中有多个word文档我真正想要的是列出文档名称并检查这些文档是否包含一些指定的单词。

我创建了两个word文档来解释。
文件夹中有两个文档Doc A和Doc B

我想在Excel列A中列出文件名Doc A和Doc B。
在A列中列出文档名称后，我想检查文档中是否有指定的单词“classification”和“Statistics”。
如果文档中有这些指定的单词，则会在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

也许这段代码会帮助你，它确实：

假设您有一个带有三个标题的活动表设置
循环指定文件夹中的.docx文件
检查指定tekst的wordrange

返回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对象库才能使用

VBA在内容中查找单词文档和指定单词，然后在excel中列出

1 个答案: