如何添加输入框来搜索指定文件夹中所有文件中的单词

Question

我使用下面由 Macropod 创建的宏来运行指定文件夹中的所有文件以搜索所需的单词。

如何通过输入框输入搜索词而不是手动调整 VBA 代码？

Sub CollateDocumentData()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, strDocNm As String, strTmp As String, strOut As String
    Dim wdDoc As Document, i As Long: Const StrFnd As String = "than,and"
    strDocNm = ActiveDocument.FullName
    strFolder = GetFolder: If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strFolder & "\" & strFile <> strDocNm Then
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        strTmp = ""
        With wdDoc
          With .range.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            For i = 0 To UBound(Split(StrFnd, ","))
              .Text = Split(StrFnd, ",")(i)
              .Execute
              If .Found = True Then strTmp = strTmp & vbCr & "" & Split(StrFnd, ",")(i)
            Next
          End With
          If strTmp <> "" Then strOut = strOut & vbCr & strFile & ": " & strTmp & Chr(13)
          .Close SaveChanges:=True
        End With
      End If
      strFile = Dir()
    Wend
    Set wdDoc = Nothing

    'If you want the results to be given in a new temporary document, remove the 'MsgBox' line below
    'If you want the results to be given in a message box within the current document, remove the 'Document.Add' and 'ActiveDocument' lines below
    'Documents.Add
    'ActiveDocument.range.Text = "The following matches were made:" & strOut
    MsgBox ("The following matches were made:" & vbCr & strOut)
    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

Answer 1

1. "\*.doc"

   所以您只想要

   .doc

   文件，也不需要

   .docx

   或

   .docm

   ？

搜索单词

搜索所需的单词。

但是

.Replacement.Text = ""

所以你想清除单词而不仅仅是搜索？而且你的代码中，没有使用Replace参数

.Execute

，它是如何正常工作的？

3. 如果你不想清除这些文字，那么你不应该设置参数

   .Replacement.Text = ""

   ，我将在下面的代码中首先执行此操作。

4. 如果你不清楚单词，也没有标记可做，为什么需要

   .Close SaveChanges:=True

   ？运行代码时该文档中根本没有任何修改。

总结以上内容，所以我想像这样重写您的代码：

Sub CollateDocumentData()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, strDocNm As String, strTmp As String, strOut As String
    'Dim wdDoc As Document, i As Long: Const StrFnd As String = "than,and"
    
    Dim wdDoc As Document, i As Long
    Static StrFnd As String, StrFndArr As Variant, UBStrFndArr As Integer
    
    StrFnd = VBA.Trim(VBA.InputBox("Plz input the words you want to find! " & vbCr & vbCr _
                            & "Please separate each word with a comma and no spaces!", "Input the words to find", StrFnd))
    If StrFnd = "" Then Exit Sub
    StrFndArr = Split(StrFnd, ",")
    UBStrFndArr = UBound(StrFndArr)
    
    strDocNm = ActiveDocument.FullName
    'strFolder = GetFolder: If strFolder = "" Then Exit Sub
    strFolder = GetFolder(): If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    
    While strFile <> ""
      'If strFolder & "\" & strFile <> strDocNm Then
      If VBA.StrComp(strFolder & "\" & strFile, strDocNm) <> 0 Then
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        strTmp = ""
        With wdDoc
          With .Range.Find
            .ClearFormatting
            '.Replacement.ClearFormatting
            '.Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            For i = 0 To UBStrFndArr 'UBound(Split(StrFnd, ","))
              .Text = StrFndArr(i) 'Split(StrFnd, ",")(i)
              .Execute 'Replace:=wdReplaceAll
              If .Found = True Then strTmp = strTmp & vbCr & "" & StrFndArr(i) 'Split(StrFnd, ",")(i)
            Next
          End With
          If strTmp <> "" Then strOut = strOut & vbCr & strFile & ": " & strTmp & Chr(13)
'          If Not .Saved Then
'            .Close SaveChanges:=True
'          Else
            .Close
'          End If
        End With
      End If
      strFile = Dir()
    Wend
    Set wdDoc = Nothing
    
    'If you want the results to be given in a new temporary document, remove the 'MsgBox' line below
    'If you want the results to be given in a message box within the current document, remove the 'Document.Add' and 'ActiveDocument' lines below
    'Documents.Add
    'ActiveDocument.range.Text = "The following matches were made:" & strOut
    MsgBox ("The following matches were made:" & vbCr & strOut)
    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

这是你想要的吗？

如果您只是想查找并返回搜索结果，那么使用

VBA.InStr

函数和

Content.Text

会更高效。

Sub CollateDocumentData_InstrContent()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, strDocNm As String, strTmp As String, strOut As String
    'Dim wdDoc As Document, i As Long: Const StrFnd As String = "than,and"
    
    Dim wdDoc As Document, i As Long
    Static StrFnd As String, StrFndArr As Variant, UBStrFndArr As Integer
    
    StrFnd = VBA.Trim(VBA.InputBox("Plz input the words you want to find! " & vbCr & vbCr _
                            & "Please separate each word with a comma and no spaces!", "Input the words to find", StrFnd))
    If StrFnd = "" Then Exit Sub
    StrFndArr = Split(StrFnd, ",")
    UBStrFndArr = UBound(StrFndArr)
    
    strDocNm = ActiveDocument.FullName
    'strFolder = GetFolder: If strFolder = "" Then Exit Sub
    strFolder = GetFolder(): If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    
    While strFile <> ""
      'If strFolder & "\" & strFile <> strDocNm Then
      If VBA.StrComp(strFolder & "\" & strFile, strDocNm) <> 0 Then
        Set wdDoc = VBA.GetObject(strFolder & "\" & strFile)
        strTmp = ""
        With wdDoc
            For i = 0 To UBStrFndArr
              If VBA.InStr(1, .Content.Text, StrFndArr(i), vbTextCompare) Then
                strTmp = strTmp & vbCr & "" & StrFndArr(i)
              End If
            Next
            If strTmp <> "" Then strOut = strOut & vbCr & strFile & ": " & strTmp & Chr(13)
          
            .Close

        End With
      End If
      strFile = Dir()
    Wend
    Set wdDoc = Nothing
    
    'If you want the results to be given in a new temporary document, remove the 'MsgBox' line below
    'If you want the results to be given in a message box within the current document, remove the 'Document.Add' and 'ActiveDocument' lines below
    'Documents.Add
    'ActiveDocument.range.Text = "The following matches were made:" & strOut
    MsgBox ("The following matches were made:" & vbCr & strOut)
    Application.ScreenUpdating = True
End Sub