Scribd
Upload
22 views2 pages

5

Uploaded by

jonalynmagsino23
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
22 views2 pages

5

Uploaded by

jonalynmagsino23
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 2

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

You might also like