Need List of Files Containing Specific Text

I have to update all .dot files that contain 1 of 2 specific text strings within the body of the file. I estimate that about 1,500 out of 14,000+ files will need to be updated. Rather than manually go through all 14,000+ files trying to find the ones I need to edit, is it possible for a macro to search through a selected directory and search all files in folders and subfolders within that directory, then in a separate document use a table to return:

-- the filepath
-- the filename
-- the text string that was found

for any files that contain either of the 2 text strings?

Also, some files are locked, so they may need to be unlocked in order to do the search. The results could be in a Word document or an Excel spreadsheet.

Thanks for your help!

Cheryl

Yes it would be possible. It would probably take a fair amount of time and some human interface would have to provide any password to "locked" files.
Are you wanting help writing this macro or you wanting someone to write it for you? What have you tried?

Code:

---

Option Explicit


Sub SearchFolders()
    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String


    On Error GoTo ErrHandler
    Application.ScreenUpdating = False


    'Change as desired
    strPath = "c:\Users\My\Desktop\"            '////////////////  <--- Change directory here  \\\\\\\\\\\\\\\\\\\\\\\\
    strSearch = "To"          '/////////////////    <--- Change term to search for here    \\\\\\\\\\\\\\\\\\\\\\\

    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "Cell"
        .Cells(lRow, 4) = "Text in Cell"
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)


        strFile = Dir(strPath & "\*.xlsx")  '<-- Currently searching all Excel files. Change extension here
        Do While strFile <> ""
            Set wbk = Workbooks.Open _
              (Filename:=strPath & "\" & strFile, _
              UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)


            For Each wks In wbk.Worksheets
                Set rFound = wks.UsedRange.Find(strSearch)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                        .Cells(lRow, 1) = wbk.Name
                        .Cells(lRow, 2) = wks.Name
                        .Cells(lRow, 3) = rFound.Address
                        .Cells(lRow, 4) = rFound.Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            Next


            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit
    End With
    MsgBox "Done"


ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub


ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

---

What is the purpose of:

Code:

---

Dim fso as Object
Dim fld as Object
...
Set fso = CreateObject("Scripting.FileSystemObject")
 Set fld = fso.GetFolder(strPath)
...
Set fld = Nothing
Set fso = Nothing

---

Yes you loop through the files in a folder, but you do not loop through any files in any sub-folders of that folder.

I overlooked the OP request for sub directories. I am certain the macro can be edited to accomplish that.

How would you accomplish that task ?

I would pass the root folder to a recursive function that returned I and all subfolders:

Code:

---

Option Explicit
Sub BatchProcessFolderAndSubFolders()
Dim vFolders As Variant
Dim lngIndex As Long
Dim strPath As String
Dim strfilename As String
  vFolders = fcnGetSubfolders("d:\My Documents\Word\Word Documents\Word Tips\Macros")
  For lngIndex = LBound(vFolders) To UBound(vFolders)
    strPath = vFolders(lngIndex)
    On Error GoTo Err_NoFiles
    strfilename = Dir$(strPath & "*.do*")
    While Len(strfilename) <> 0
      'You could open the file here and pass it to a function to do something to it.
      Debug.Print strfilename
      strfilename = Dir$()
    Wend
ReEntry:
  Next
lbl_Exit:
  Exit Sub
Err_NoFiles:
  Resume ReEntry
End Sub
Public Function fcnGetSubfolders(ByVal FolderToRead As String) As Variant
Dim AllSubFolders(0) As Variant
  On Error Resume Next
  System.Cursor = wdCursorWait
  If (Right$(FolderToRead, 1) <> "\") Then FolderToRead = FolderToRead & "\"
  'Set the path as the first entry in the array and pass the array to the main function.
  AllSubFolders(0) = FolderToRead
  fcnGetSubfolders = fcnGetAllSubfolders(AllSubFolders)
  System.Cursor = wdCursorNormal
  'StatusBar = ""
  On Error GoTo 0
lbl_Exit:
  Exit Function
End Function
Private Function fcnGetAllSubfolders(ByVal AllSubFoldersArray As Variant) As Variant
'This is a recursive function, that is it calls itself as required.
Dim lngCounter As Long
Dim strCurrentFolderName As String
Dim strSubFolderName As String
Dim arrSubFolderList() As String
  On Error Resume Next
  strCurrentFolderName = CStr(AllSubFoldersArray(UBound(AllSubFoldersArray)))
  ReDim arrSubFolderList(0)
  strSubFolderName = Dir$(strCurrentFolderName, vbDirectory)
  Do While Len(strSubFolderName) <> 0
    If strSubFolderName <> "." _
      And strSubFolderName <> ".." _
      And InStr(1, strSubFolderName, "?") = 0 Then
      If (GetAttr(strCurrentFolderName & strSubFolderName) And vbDirectory) = vbDirectory Then
        ReDim Preserve arrSubFolderList(UBound(arrSubFolderList) + 1)
        arrSubFolderList(UBound(arrSubFolderList)) = strSubFolderName
        'StatusBar = "Reading Subfolders... (" & strCurrentFolderName & ": -> " & strSubFolderName & ")"
      End If
    End If
    strSubFolderName = Dir$()
  Loop
  'Sort the list with the subfolders.
  If UBound(arrSubFolderList) > 0 Then WordBasic.SortArray arrSubFolderList()
  For lngCounter = 1 To UBound(arrSubFolderList)
    'Up the size of the AllSubFoldersArray array by one
    ReDim Preserve AllSubFoldersArray(UBound(AllSubFoldersArray) + 1)
    AllSubFoldersArray(UBound(AllSubFoldersArray)) = _
      strCurrentFolderName & arrSubFolderList(lngCounter) & "\"
    AllSubFoldersArray = fcnGetAllSubfolders(AllSubFoldersArray)
  Next lngCounter
  fcnGetAllSubfolders = AllSubFoldersArray
  On Error GoTo 0
End Function

---

My apologies. Just realized OP is dealing with WORD documents, not Excel.

Have a great day !

My appologiesfor writing on the same thread, but I have run the code, it gives a runtime error

Unless it is a state secret can you provide the runtime error number and where in the code it appears?

variable not found wdCursorWait

sorry, compile error

Try removing the lines dealing with the cursor.

yes it works without it

thank you...

I know this was posted some time ago, but I've tested it and it's working great.
I'm using it to search through excel files in a SharePoint folder.
What I need to do is loop at the strSearch for several different text strings.
I'm not sure how to have it loop at this point. Can you help please?

Code:

---

'Change as desired
    strPath = "c:\Users\My\Desktop"            '////////////////  <--- Change directory here  \\\\\\\\\\\\\\\\\\\\\\\\
    strSearch = "To"          '/////////////////    <--- Change term to search for here    \\\\\\\\\\\\\\\\\\\\\\\

---

Sincerely,
Mike

Hi, The code in Search All Files For Term.xlsm is working great. however I have similar request as one of the user asked..is it possible to
1) Search through Cells from A2 to A1500 one by one & 2) Save file names in individual sheets with sheet name same as cell values (A2 to A1500 - already present in workbook) at cell address specified in column B (B2 to B1500)
Attachment 25236
Snapshot attached - example search for #cmsga (text in b2) in list of text files at D:\textfiles and save file names at location specified in C2 of sheet with same name as B2

Thanks
Jignesh

Hi Sir I know its that too far from the time its posted but i've tried it then it goes compile error i followed the method in deleting the cursor.

thank you regards
giox

Quote:

---

Originally Posted by gmaxey

I would pass the root folder to a recursive function that returned I and all subfolders:

Code:

---

Option Explicit
Sub BatchProcessFolderAndSubFolders()
Dim vFolders As Variant
Dim lngIndex As Long
Dim strPath As String
Dim strfilename As String
  vFolders = fcnGetSubfolders("d:\My Documents\Word\Word Documents\Word Tips\Macros")
  For lngIndex = LBound(vFolders) To UBound(vFolders)
    strPath = vFolders(lngIndex)
    On Error GoTo Err_NoFiles
    strfilename = Dir$(strPath & "*.do*")
    While Len(strfilename) <> 0
      'You could open the file here and pass it to a function to do something to it.
      Debug.Print strfilename
      strfilename = Dir$()
    Wend
ReEntry:
  Next
lbl_Exit:
  Exit Sub
Err_NoFiles:
  Resume ReEntry
End Sub
Public Function fcnGetSubfolders(ByVal FolderToRead As String) As Variant
Dim AllSubFolders(0) As Variant
  On Error Resume Next
  System.Cursor = wdCursorWait
  If (Right$(FolderToRead, 1) <> "\") Then FolderToRead = FolderToRead & "\"
  'Set the path as the first entry in the array and pass the array to the main function.
  AllSubFolders(0) = FolderToRead
  fcnGetSubfolders = fcnGetAllSubfolders(AllSubFolders)
  System.Cursor = wdCursorNormal
  'StatusBar = ""
  On Error GoTo 0
lbl_Exit:
  Exit Function
End Function
Private Function fcnGetAllSubfolders(ByVal AllSubFoldersArray As Variant) As Variant
'This is a recursive function, that is it calls itself as required.
Dim lngCounter As Long
Dim strCurrentFolderName As String
Dim strSubFolderName As String
Dim arrSubFolderList() As String
  On Error Resume Next
  strCurrentFolderName = CStr(AllSubFoldersArray(UBound(AllSubFoldersArray)))
  ReDim arrSubFolderList(0)
  strSubFolderName = Dir$(strCurrentFolderName, vbDirectory)
  Do While Len(strSubFolderName) <> 0
    If strSubFolderName <> "." _
      And strSubFolderName <> ".." _
      And InStr(1, strSubFolderName, "?") = 0 Then
      If (GetAttr(strCurrentFolderName & strSubFolderName) And vbDirectory) = vbDirectory Then
        ReDim Preserve arrSubFolderList(UBound(arrSubFolderList) + 1)
        arrSubFolderList(UBound(arrSubFolderList)) = strSubFolderName
        'StatusBar = "Reading Subfolders... (" & strCurrentFolderName & ": -> " & strSubFolderName & ")"
      End If
    End If
    strSubFolderName = Dir$()
  Loop
  'Sort the list with the subfolders.
  If UBound(arrSubFolderList) > 0 Then WordBasic.SortArray arrSubFolderList()
  For lngCounter = 1 To UBound(arrSubFolderList)
    'Up the size of the AllSubFoldersArray array by one
    ReDim Preserve AllSubFoldersArray(UBound(AllSubFoldersArray) + 1)
    AllSubFoldersArray(UBound(AllSubFoldersArray)) = _
      strCurrentFolderName & arrSubFolderList(lngCounter) & "\"
    AllSubFoldersArray = fcnGetAllSubfolders(AllSubFoldersArray)
  Next lngCounter
  fcnGetAllSubfolders = AllSubFoldersArray
  On Error GoTo 0
End Function

---

---

That code does not throw a compile error in Word 2007, 2010, 2013, 2016 or 2020.

What compile error. What line of code.