benson8708
11-15-2016, 10:52 AM
How can I get this code to search all included subfolders within the selected folder? The code below will prompt me to enter a folder and then prompt a search string. It works perfectly except it will not search any sub folders with in the selected folder.
Please advise.
Sub SearchWKBooks()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
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") = "Workbook"
WS.Range("B3") = "Worksheet"
WS.Range("C3") = "Cell Address"
WS.Range("D3") = "Link"
a = 0
Value = Dir(myfolder)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Right(Value, 4) = "xlsx" And Left(Value, 4) = "Zone" Then
On Error Resume Next
Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
If Err.Number > 0 Then
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = "Password protected"
a = a + 1
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not c Is Nothing Then
firstAddress = c.Address
Do
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = sht.Name
WS.Range("C4").Offset(a, 0).Value = c.Address
WS.Hyperlinks.Add Anchor:=WS.Range("D4").Offset(a, 0), Address:=myfolder & Value, SubAddress:= _
sht.Name & "!" & c.Address, TextToDisplay:="Link"
a = a + 1
Set c = sht.Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
Cells.EntireColumn.AutoFit
End Sub
Please advise.
Sub SearchWKBooks()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
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") = "Workbook"
WS.Range("B3") = "Worksheet"
WS.Range("C3") = "Cell Address"
WS.Range("D3") = "Link"
a = 0
Value = Dir(myfolder)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Right(Value, 4) = "xlsx" And Left(Value, 4) = "Zone" Then
On Error Resume Next
Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
If Err.Number > 0 Then
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = "Password protected"
a = a + 1
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not c Is Nothing Then
firstAddress = c.Address
Do
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = sht.Name
WS.Range("C4").Offset(a, 0).Value = c.Address
WS.Hyperlinks.Add Anchor:=WS.Range("D4").Offset(a, 0), Address:=myfolder & Value, SubAddress:= _
sht.Name & "!" & c.Address, TextToDisplay:="Link"
a = a + 1
Set c = sht.Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
Cells.EntireColumn.AutoFit
End Sub