How to add an InputBox to search for words within all files in a designated folder

Question

I use the macro below, created by Macropod, to run through all files in a designated folder to search for desired words.

How could the search terms be entered via an InputBox rather than manually adjusting the VBA code?

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" So you only want .doc file nor .docx or .docm?

to search for words

to search for desired words.

However .Replacement.Text = "" so you want to clear the words not search only? And in your code, there is no parameter Replace used to .Execute, how does it work properly?

3. If you do not want to clear the words, then you shouldn't set the parameter .Replacement.Text = "", and I'll do this first in my code below.

4. If you do not clear the words and have no marks to do, why do you need .Close SaveChanges:=True? There is no modification at all in that document while running the code.

Conclude the above so I'd like to rewrite your code like this:

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

Is this what you want?

If you just want to find and return the search result then using VBA.InStr function and Content.Text will be more efficient.

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