PDA

View Full Version : Solved: Open Directory Macro



Anne Troy
01-07-2009, 11:35 AM
Would LOVE to be able to have a macro that looks at the value in cell D10 and opens the folder by that name.

All of these folders will reside in S:\File Cabinet\PSI Sales Orders

However, folders 17 through 1118 are directly under PSI Sales Orders.

All other folders, 1119 and above, are in group folders:

1119 - 1200
1201 - 1300
1301 - 1400
1401 - 1500
and so on...

For instance, I might have a folder called 4412.
I type 4412 into cell D10 and run my macro.
The folder in which folder 4412 exists (S:\File Cabinet\PSI Sales Orders\4401 - 4500\4412) opens in Windows Explorer.

If the folder doesn't exist, I'd LOVE to get:

"The folder doesn't exist. Would you like to create it?" (Y/N)

I can edit the code to suit my needs and I can create methods to run the code. I just can't write it. Will you?

THANKS!!!!!

Bob Phillips
01-07-2009, 11:57 AM
Anne,

What do you mean by open the folder.

And if the folder doesn't exist, how will you know at which level and along which path to create it?

Anne Troy
01-07-2009, 12:20 PM
LOL. Thanks, Bob.

What do you mean by open the folder?
I mean view the contents of the folder in Windows Explorer.

And if the folder doesn't exist, how will you know at which level and along which path to create it?
Let's just skip that part. It's not even necessary.

Thanks, Bob! I try so hard to cover all the bases...

Bob Phillips
01-07-2009, 04:20 PM
Anne,

try this event code



Option Explicit

Private FSO As Object
Private Const PATH_ROOT As String = "S:\File Cabinet\PSI Sales Orders"

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "D10" '<== change to suit

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then

Set FSO = CreateObject("Scripting.FileSystemObject")

With Target

FindFolder PATH_ROOT, .Value
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

Private Function FindFolder(ByVal Path As String, ByVal FileDir As String)
Dim mpFolder As Object
Dim mpSubFolder As Object

Set mpFolder = FSO.GetFolder(Path)
For Each mpSubFolder In mpFolder.SubFolders

If mpSubFolder.Name = FileDir Then

Shell "C:\WINDOWS\EXPLORER.EXE """ & mpSubFolder.Path & """", 1
Exit For
Else

FindFolder mpSubFolder.Path, FileDir
End If
Next mpSubFolder

End Function


This is worksheet event code, which means that it needs to be
placed in the appropriate worksheet code module, not a standard
code module. To do this, right-click on the sheet tab, select
the View Code option from the menu, and paste the code in.

Kenneth Hobs
01-08-2009, 10:01 AM
Searching a few folders using Bob's fine FSO method is fast. However, if you are like me which I hope not, you may have a large numbers of subfolders. In one drive I have 2300 subfolders. Using the method that I will post at the end which is similar to Bob's, it took 55 seconds to find the last subfolder. My function at the end will return true or false if the subfolder exists and updates a referenced string variable with the path to the subfolder.

If you really want to pursue the scenario above, we can try some other search methods. I have a DOS method that worked about 3 times faster than one FSO method.

A decent trade-off would be to guess at the subfolder path since we know Anne's folder naming convention. Anne, put this code in a Module and run OpenOrMakeSubFolder from any active cell.
'Note: use no trailing path separator.
Private Const rootFolder As String = "S:\File Cabinet\PSI Sales Orders"

Sub OpenOrMakeSubFolder()
Dim cat As String 'Category string, "1119 - 1200"
Dim sf As String 'SubFolder string, e.g. 1121
Dim ac As Range 'The current active cell with sf.
Dim fp As String 'Full Path.
Dim ps As String 'Path Separator character, "\"

Set ac = ActiveCell
sf = ac.Value
ps = Application.PathSeparator
fp = rootFolder
Select Case VarType(ac)
Case 8 'sf is a string.
If Len(sf) = Val(sf) Then
sf = CLng(sf)
GoTo CaseNumber
End If
fp = fp & ps & sf
ShowCreateFP fp
Case 2 To 5 'sf must be a number
CaseNumber:
Select Case True
Case sf < 1119
fp = fp & ps & sf
ShowCreateFP fp
Case sf > 1118 And sf < 1201
cat = "1119 - 1200"
fp = fp & ps & cat & ps & sf
ShowCreateFP fp
Case Else
cat = Bot100P1(sf) & " - " & Top100(sf)
fp = fp & ps & cat & ps & sf
ShowCreateFP fp
End Select
Case Else
MsgBox "Failed to guess folder.", vbCritical, "Exit"
Explore rootFolder
End Select
End Sub

Sub ShowCreateFP(fp As String)
If FolderExist(fp) Then
Explore fp
ElseIf vbYes = MsgBox(fp & vbCrLf & "File above does not exist." & vbCrLf & _
"Would you like to create and open it?", vbYesNo + vbInformation, "Not Found") Then
Shell "cmd /c md " & """" & fp & """", vbHide 'Create the folder
Explore fp
End If
End Sub

Function FolderExist(folder As String) As Boolean
FolderExist = Dir(folder, vbDirectory) <> vbNullString
End Function

Sub Explore(folder As String)
Dim x As Variant
If Left(folder, 1) <> """" Then folder = """" & folder & """"
x = Shell("explorer /n,/e," & folder, 1)
End Sub

Function Top100(ByVal x As Long) As Long
While (x Mod 100 <> 0)
x = x + 1
Wend
Top100 = x
End Function

Function Bot100P1(ByVal x As Long) As Long
If x Mod 100 = 0 Then x = x - 1
While (x Mod 100 <> 0)
x = x - 1
Wend
Bot100P1 = x + 1
End Function

Here is my modified version of Bob's code. The Sub Test shows the time it takes to find or not find the subfolder.

Sub Test()
Dim s As String, rc As Boolean
Dim t As Double
t = Timer
rc = SubFolderExist("t:", "xml", s)
Debug.Print Timer - t & " seconds."
End Sub

Sub Test_SubFolderExist()
Dim s As String, rc As Boolean
rc = SubFolderExist(ThisWorkbook.Path, "t", s)
Debug.Print rc, s
End Sub

'Similar to xld's, http://vbaexpress.com/forum/showthread.php?t=24561
Private Function SubFolderExist(ByVal Path As String, ByVal FileDir As String, _
Optional ByRef SubFolderPath As String) As Boolean
Dim mpFolder As Object
Dim mpSubFolder As Object
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set mpFolder = fso.GetFolder(Path)
For Each mpSubFolder In mpFolder.SubFolders
If LCase(mpSubFolder.Name) = LCase(FileDir) Then
'Shell "C:\WINDOWS\EXPLORER.EXE """ & mpSubFolder.Path & """", 1
SubFolderPath = mpSubFolder.Path
SubFolderExist = True
Exit For
Else
SubFolderExist mpSubFolder.Path, FileDir
End If
Next mpSubFolder
Set fso = Nothing
End Function

Anne Troy
01-08-2009, 10:06 AM
It's beautiful, and works great, except for one thing. It opens Explorer. Then, when I close Explorer and go back to Excel, it hangs, then finally "releases". It's still lots faster than what I would otherwise need to use. Thanks so much for saving my life AGAIN, Bob. :)

Anne Troy
01-08-2009, 10:12 AM
That's what I get for not refreshing before I post. I did use your code, Ken, and it's quite a bit faster, actually. You're right, there are actually 5500 folders total to look through.

Thanks so much!!