代码之家 › 专栏 › 技术社区 › Peter Chen

vba在内容中查找word文档和指定单词,然后在excel中列出

ms-word excel-vba vba excel

-2

Peter Chen · 技术社区 · 6 年前

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

例如,我创建了两个单词的文档来解释。
有两份文件, Doc A 和 Doc B ,在文件夹中。

我想列出文件名 文档A 和 博士B 在excel列a中。
在A列中列出文档名称后,我想检查文档中是否有指定的“分类”和“统计”字样。
如果文档中有这些指定的单词,它将在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.

有人能帮我编辑代码吗?

1 回复 | 直到 6 年前

JvdV 6 年前

也许这段代码能帮你解决问题,它确实:

假设有一个activesheet设置,其中有三个header
循环浏览指定文件夹中的.docx文件
检查指定tekst的wordrange

返回true或false,并在适当的单元格中放置found或not found

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对象库才能运行