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