PDA

View Full Version : VBA Code will not search subfolders.



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

benson8708
11-15-2016, 01:58 PM
Anybody?

Kenneth Hobs
11-15-2016, 07:02 PM
There are two methods to get subfolder file paths. You can use a scripting.filesystemobject (FSO) recursive method or one like this:

Sub aFFs_Test()
Dim x() As Variant, s() As String, i As Long
x() = aFFs("c:\myfiles\excel\msword\*.doc")
MsgBox Join(x, vbLf)
For i = LBound(x) To UBound(x)
'Do your thing here, e.g.
'MsgBox x(i)
Next i
End Sub


Sub MyFoldersAndDatesCreated()
Dim a() As Variant, b() As Variant, i As Long
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

a() = aFFs("x:\", "/ad", True)

'MsgBox Join(a(), vbLf)
Range("A1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(a)

b() = a() 'Set array to holder folder creation dates the same size
For i = LBound(a) To UBound(a)
b(i) = fso.GetFolder(b(i)).DateCreated
Next i

Range("B1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(b)

Range("A:B").EntireColumn.AutoFit
End Sub




'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
MsgBox myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function

benson8708
11-16-2016, 08:36 AM
Thanks for that. That code is a little above my pay grade. I ran it and it propagates a list of all the subfolders, but how do I use that info with the code that I already had? Is there away to integrate that in to my existing code?

Kenneth Hobs
11-16-2016, 10:43 AM
I guess that I could finish this for you but you will learn more doing it yourself. I added a bit more FSO to show you how to parse the full path filename to use as you see fit. The more efficient way would be to dim and array with the the first elements being say 0 to 3 for your first 4 columns of data, and then write the array all at once. I used a single dimension array for illustration purposes mostly but even that is far faster than writing out one cell at a time.

It should not take that much work to concatenate the folder from your current code to the "Zone*.xlsx" to pass to my aFFs() routine. Here again, that is far faster than, getting all files and running If's to check file extension and filename suffix.


Sub MyFoldersAndDatesCreated()
Dim a() As Variant, b() As Variant, i As Long
Dim fso As Object
Dim c() As Variant, d() As Variant

'FSO Details: https://msdn.microsoft.com/en-us/library/hww8txat(v=vs.84).aspx
Set fso = CreateObject("Scripting.FileSystemObject")

'a() = aFFs("x:\", "/ad", True) 'Folders only
a() = aFFs("x:\Zone*.xlsx", , True) 'Wildcard filenames

'MsgBox Join(a(), vbLf)
Range("A1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(a)

b() = a()
c() = a()
d() = a()
For i = LBound(a) To UBound(a)
'Get folder's date created
'b(i) = fso.GetFolder(b(i)).DateCreated
'Get file's basename
b(i) = fso.GetBasename(b(i)) 'No file extension
c(i) = fso.GetParentFoldername(a(i)) 'Parent Folder Name
'd(i) = fso.Getfile(a(i)).Name 'Get only file basename with file extension
d(i) = fso.GetFilename(a(i)) 'Another way to get only file basename with file extension
Next i

Range("B1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(b)
Range("C1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(c)
Range("D1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(d)

Range("A:D").EntireColumn.AutoFit
End Sub