Using VBA to search for defined text in multiple folders

DavidAC

Board Regular
Joined
Feb 10, 2003
Messages
134
Office Version
  1. 365
good morning,
we have a number of files spread over several folders on our server where we need to search for data across the folders. We need to define which folders we want to search across at the same time. We don't want to search everything on the server just the folders selected. We are currently using this code which works great but you have to select each folder separately which is time consuming. Is there a way to either select multiple folders or code it so that we can put the folder location into the vba?

VBA Code:
Public WS As Worksheet
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
ReDim Folders(0)
If IsMissing(Folderpath) Then
    Set WS = Sheets.Add
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        myfolder = .SelectedItems(1) & "\"
    End With
    Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
    If Str = "" Then Exit Sub
    WS.Range("A1") = "Search string:"
    WS.Range("B1") = Str
    WS.Range("A2") = "Path:"
    WS.Range("B2") = myfolder
    WS.Range("A3") = "Folderpath"
    WS.Range("B3") = "Workbook"
    WS.Range("C3") = "Worksheet"
    WS.Range("D3") = "Cell Address"
    WS.Range("E3") = "Link"
    Folderpath = myfolder
    Value = Dir(myfolder, &H1F)
Else
    If Right(Folderpath, 2) = "\\" Then
        Exit Sub
    End If
    Value = Dir(Folderpath, &H1F)
End If
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If GetAttr(Folderpath & Value) = 16 Then
            Folders(UBound(Folders)) = Value
            ReDim Preserve Folders(UBound(Folders) + 1)
        ElseIf (Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm") And Left(Value, 1) <> "~" Then
            On Error Resume Next
            Dim wb As Workbook
            Set wb = Workbooks.Open(Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz")
            On Error GoTo 0
            'If there is an error on Workbooks.Open, then wb Is Nothing:
            If wb Is Nothing Then
                Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
                WS.Range("A" & Lrow).Value = Value
                WS.Range("B" & Lrow).Value = "Password protected"
            Else
                For Each sht In wb.Worksheets
                    'Expand all groups in sheet
                    sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
                    Set c = sht.Cells.Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                    If Not c Is Nothing Then
                        firstAddress = c.Address
                        Do
                            Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
                            WS.Range("A" & Lrow).Value = Folderpath
                            WS.Range("B" & Lrow).Value = Value
                            WS.Range("C" & Lrow).Value = sht.Name
                            WS.Range("D" & Lrow).Value = c.Address
                            WS.Hyperlinks.Add Anchor:=WS.Range("E" & Lrow), Address:=Folderpath & Value, SubAddress:= _
                            "'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
                            Set c = sht.Cells.FindNext(After:=c)

                        Loop While Not c Is Nothing And c.Address <> firstAddress
                    End If
                Next sht
                wb.Close False
            End If
        End If
    End If
    Value = Dir
Loop
For Each Folder In Folders
    Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)
Next Folder
Cells.EntireColumn.AutoFit
End Sub
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Is the folder list static? Then you could use a list.
If all the folders to search were subfolders you could use a recursive sub to iterate over all the subfolders of the chosen parent folder.
Sorry, I didn't study the code because you can't multi select with msoFileDialogFolderPicker anyway so there's no adapting that code for that dialog.
 
Upvote 0
Here an example of recursion. You need all folders to be subfolders as already mentioned by Micron.

VBA Code:
Dim ar() As Variant, x As Long

Public Sub file_search()
 getFile "C:\Users\xxx\Documents\"
 MsgBox x & " files" & vbLf & Join(ar, vbLf)    'instead of  this line, you could use the array "ar" to write to the sheet.
 End
End Sub

Public Sub getFile(objFolderPath As String)
 Dim sFold, it, sf
 With CreateObject("scripting.filesystemobject")
    Set sFold = .GetFolder(objFolderPath)
    For Each it In sFold.Files
       If .GetExtensionName(it) Like "xls*" Then
          ReDim Preserve ar(x)
          ar(x) = it.Path
          x = x + 1
       End If
    Next
    For Each sf In sFold.SubFolders
       getFile sf.Path
    Next
 End With
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top