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

Question

I have been using the excellent macro below, created by Macropod an posted in another forum, to run through all files in a designated folder to search for desired words. It works perfectly but I was wondering how to adjust it so that the search terms could be entered via an InputBox rather than having to manually adjust the VBA code each time.

Any help is greatly appreciated.

Many thanks in advance.

Luke

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

Oscar Sun · Accepted Answer · 2023-07-07T06:10:50.480

"\*.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?

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.
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

Hi Oscar, that's amazing thank you! Works perfectly. You're right - I only need to search and not replace. Regarding the file extension, I only need to check .doc and .docx files. Thanks again! — Luke, Jul 07 '23 at 06:05
@Luke so would you like to accept this answer and close your question? — Oscar Sun, Jul 07 '23 at 06:08

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

1 Answers1