Need List of Files Containing Specific Text

[clhare]

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

[gmaxey]

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?

[Logit]

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

[gmaxey]

What is the purpose of:


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.

[Logit]

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 ?

[gmaxey]

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


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

[Logit]

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

Have a great day !

[sibjac]

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

[gmaxey]

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

[sibjac]

variable not found wdCursorWait

[sibjac]

sorry, compile error

[gmaxey]

Try removing the lines dealing with the cursor.

[sibjac]

yes it works without it

[sibjac]

thank you...

[mwyller]

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?


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

Sincerely,
Mike

[jigneshwaghe]

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

[giox]

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




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


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

[gmaxey]

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

What compile error. What line of code.