Consulting

Results 1 to 18 of 18

Thread: Need List of Files Containing Specific Text

  1. #1
    VBAX Mentor clhare's Avatar
    Joined
    Mar 2005
    Posts
    470
    Location

    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

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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?
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    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
    Attached Files Attached Files

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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.
    Last edited by Aussiebear; 04-19-2023 at 04:24 AM. Reason: Added code tags
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    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 ?

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  7. #7
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    My apologies. Just realized OP is dealing with WORD documents, not Excel.

    Have a great day !

  8. #8
    VBAX Regular
    Joined
    Dec 2017
    Posts
    21
    Location
    My appologiesfor writing on the same thread, but I have run the code, it gives a runtime error

  9. #9
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Unless it is a state secret can you provide the runtime error number and where in the code it appears?
    Greg

    Visit my website: http://gregmaxey.com

  10. #10
    VBAX Regular
    Joined
    Dec 2017
    Posts
    21
    Location
    variable not found wdCursorWait

  11. #11
    VBAX Regular
    Joined
    Dec 2017
    Posts
    21
    Location
    sorry, compile error

  12. #12
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Try removing the lines dealing with the cursor.
    Greg

    Visit my website: http://gregmaxey.com

  13. #13
    VBAX Regular
    Joined
    Dec 2017
    Posts
    21
    Location
    yes it works without it

  14. #14
    VBAX Regular
    Joined
    Dec 2017
    Posts
    21
    Location
    thank you...

  15. #15
    VBAX Newbie
    Joined
    Mar 2018
    Posts
    1
    Location

    Love the code - can you help a VBA newbie with a question?

    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
    Last edited by Aussiebear; 04-19-2023 at 04:25 AM. Reason: Added code tags

  16. #16
    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)
    Capture.JPG
    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
    Last edited by jigneshwaghe; 10-06-2019 at 07:30 AM. Reason: Including snapshot

  17. #17
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    1
    Location
    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 View Post
    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

  18. #18
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    That code does not throw a compile error in Word 2007, 2010, 2013, 2016 or 2020.

    What compile error. What line of code.
    Greg

    Visit my website: http://gregmaxey.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •