find a folder extension macro

[stevesunfold]

hi guys
this query has now took a peculiar twist in the fact that my boss now wants to change the goalposts

here is a thread with the code in

http://www.excelforum.com/showthread.php?t=644837

thanks to broro183

Sub SaveJobFile()
'declare all variables
Dim stOfPath As String
Dim ActualMidFolder As String
Dim EndOfNameAndPath As String
Dim FileNameToSave As String
Dim JobNum As String
Dim PONum As String
Dim SuppliersName As String

'define initial variables (note: the ranges may need to be changed
    JobNum = Range("G23").Value
    PONum = Range("k12").Value
    SuppliersName = Range("b16")
    EndOfNameAndPath = SuppliersName & " Purchase Order " & PONum & Format(Date, " dd.mm.yy") & ".xls"

'test to see if it is stock or PO (?) & define the saving path accordingly
    Select Case UCase(Left(JobNum, 1)) = "J"
        Case True
'Rob's test path:     stOfPath = "C:\Documents and Settings\HP_Owner\My Documents\"
            stOfPath = Range("B69") & "\"
            'test for any likely folders
                If Not (DoesFileFolderExist(stOfPath & JobNum & "*")) Then GoTo TheEnd
            'identify the exact folder
                ActualMidFolder = GetActualFolderName(stOfPath, JobNum) & "\"
            'define rest of file name
                EndOfNameAndPath = "Docs\" & EndOfNameAndPath
                FileNameToSave = stOfPath & ActualMidFolder & EndOfNameAndPath
        Case False
            stOfPath = Range("B70") & "\"
            If Not (DoesFileFolderExist(stOfPath)) Then GoTo TheEnd
                FileNameToSave = stOfPath & EndOfNameAndPath
    End Select

'save the file & finish macro
    ActiveWorkbook.SaveAs Filename:=FileNameToSave
    Exit Sub

TheEnd:
'warn nothing exists & end the macro
    MsgBox "Macro ending b/c no Folder with the following number exists : " & stOfPath & JobNum & "*", , "FYI"
    Debug.Print stOfPath & JobNum & "*"
End Sub

Public Function DoesFileFolderExist(strfullpath As String) As Boolean
'sourced from www.excelguru.ca/node/30 by Ken Puls
'note it only checks for the existence of the lowest folder (or the file) in the strfullpath string.
If Not Dir(strfullpath, vbDirectory) = vbNullString Then DoesFileFolderExist = True
End Function

Function GetActualFolderName(StartOfPath As String, StartOfFuzzyFolder As String)
'sourced & modified from http://www.themssforum.com/ExcelProgramming/parent-folder/
Dim oFSO As Object
Dim SubDirectory
Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO.GetFolder(StartOfPath)
    For Each SubDirectory In .SubFolders
        If UCase(Left(SubDirectory.Name, Len(StartOfFuzzyFolder))) = UCase(StartOfFuzzyFolder) Then
            GetActualFolderName = SubDirectory.Name
            Exit For
        End If
    Next SubDirectory
End With
'free memory
Set oFSO = Nothing
End Function

my boss has now decided that all the old files will have a few different subfolders which will not include \docs

so what i need this code to do is look for \docs and if it doesnt exist ask it too look for the new sub folder of Ordering Docs

is this possible?
i hope so and so sorry to annoy you all again

regards

[Simon Lloyd]

Steve, Please click on the Edit button on your post click Go Advanced and change your title to something a little more descriptive its more likely to get you the response you need!

[stevesunfold]

sorry simon

[Simon Lloyd]

No worries, thanks for changing it!

[Richard Buttrey]

Steve,

This is untested since one of the Functions called uses the "File System" object syntax which isn't available on my Mac. However try it and if it works, or if broro steps in and amends his original code, then that would be good.

If not post back and I'll dig out an old PC over the weekend and try it there.

The lines I've added are in red.

Sub SaveJobFile()
'declare all variables
Dim stOfPath As String
Dim ActualMidFolder As String
Dim EndOfNameAndPath As String
Dim FileNameToSave As String
Dim JobNum As String
Dim PONum As String
Dim SuppliersName As String


'define initial variables (note: the ranges may need to be changed
    JobNum = Range("G23").Value
    PONum = Range("k12").Value
    SuppliersName = Range("b16")
    EndOfNameAndPath = SuppliersName & " Purchase Order " & PONum & Format(Date, " dd.mm.yy") & ".xls"

'test to see if it is stock or PO (?) & define the saving path accordingly
    Select Case UCase(Left(JobNum, 1)) = "J"
        Case True
'Rob's test path:     stOfPath = "C:\Documents and Settings\HP_Owner\My Documents\"
            stOfPath = Range("B69") & "\"
            'test for any likely folders
                If Not (DoesFileFolderExist(stOfPath & JobNum & "*")) Then GoTo TheEnd
            'identify the exact folder
                ActualMidFolder = GetActualFolderName(stOfPath, JobNum) & "\"
            'define rest of file name
               If Not (GetActualFolderName(stOfPath, "\Docs") & "\") Then 'added by Richard Buttrey 23/5/08
                EndOfNameAndPath = "Ordering Docs\" & EndOfNameAndPath 'added by Richard Buttrey 23/5/08
                Else 'added by Richard Buttrey 23/5/08
                EndOfNameAndPath = "Docs\" & EndOfNameAndPath
                End If 'added by Richard Buttrey 23/5/08
                FileNameToSave = stOfPath & ActualMidFolder & EndOfNameAndPath
        Case False
            stOfPath = Range("B70") & "\"
            If Not (DoesFileFolderExist(stOfPath)) Then GoTo TheEnd
                FileNameToSave = stOfPath & EndOfNameAndPath
    End Select

'save the file & finish macro
    ActiveWorkbook.SaveAs Filename:=FileNameToSave
    Exit Sub

TheEnd:
'warn nothing exists & end the macro
    MsgBox "Macro ending b/c no Folder with the following number exists : " & stOfPath & JobNum & "*", , "FYI"
    Debug.Print stOfPath & JobNum & "*"
End Sub

[stevesunfold]

yeah hi richard thanks for the reply

it returns bad file name

run timer error 52

regards

[broro183]

hi,

Sorry, I'm being a bit lazy so this is untested too - hopefully it works ;-)
(see between the stars)

I have used the same type of approach as Richard but I used the other function "doesfilefolderexist" which returns a boolean response rather than the "getactualfoldername" which gives a folder name. btw, I don't know much about fso objects either - this was really a stolen & modified function.
Also, I've inserted a second check in case the "Ordering Docs" folder doesn't exist either.

Option Explicit

Sub SaveJobFile()
'declare all variables
Dim stOfPath As String
Dim ActualMidFolder As String
Dim EndOfNameAndPath As String
Dim FileNameToSave As String
Dim JobNum As String
Dim PONum As String
Dim SuppliersName As String
Dim ChosenFolder As String

'define initial variables
    JobNum = Range("G23").Value
    PONum = Range("k12").Value
    SuppliersName = Range("b16")
    EndOfNameAndPath = SuppliersName & " Purchase Order " & PONum & Format(Date, " dd.mm.yy") & ".xls"
    ChosenFolder = "Docs" 'default value
    
'test to see if it is stock or PO (?) & define the saving path accordingly
    Select Case UCase(Left(JobNum, 1))
        Case Is = "J"
'Rob's test path:
stOfPath = "C:\Documents and Settings\HP_Owner\My Documents\"
 '           stOfPath = Range("B69") & "\"
            'test for any likely folders
                If Not (DoesFileFolderExist(stOfPath & JobNum & "*")) Then GoTo TheEnd
            'identify the exact folder
                ActualMidFolder = GetActualFolderName(stOfPath, JobNum) & "\"
'**************************************
            'Test for existence of "Docs" folder & then for existence of the alternative folder (if needed)
                If Not (DoesFileFolderExist(stOfPath & ActualMidFolder & ChosenFolder)) Then
                        ChosenFolder = "Ordering Docs"
                        If Not (DoesFileFolderExist(stOfPath & ActualMidFolder & ChosenFolder)) Then GoTo TheEnd
                End If
'**************************************
            'define rest of file name
                EndOfNameAndPath = ChosenFolder & "\" & EndOfNameAndPath
                FileNameToSave = stOfPath & ActualMidFolder & EndOfNameAndPath
        Case Else
            stOfPath = Range("B70") & "\"
            If Not (DoesFileFolderExist(stOfPath)) Then GoTo TheEnd
                FileNameToSave = stOfPath & EndOfNameAndPath
    End Select

'save the file & finish macro
    ActiveWorkbook.SaveAs Filename:=FileNameToSave
    Exit Sub

TheEnd:
'warn nothing exists & end the macro
    MsgBox "Macro ending b/c either:" & Chr(13) & _
    "1) no Folder with the following Job number exists : " & stOfPath & JobNum & "*", , "FYI" & Chr(13) & _
    "or" & Chr(13) & "2) the subfolder to save into does not exist: " & stOfPath & ActualMidFolder & ChosenFolder
    Debug.Print stOfPath & JobNum & "*"
End Sub

Public Function DoesFileFolderExist(strfullpath As String) As Boolean
'sourced from www.excelguru.ca/node/30 by Ken Puls
'note it only checks for the existence of the lowest folder (or the file) in the strfullpath string.
If Not Dir(strfullpath, vbDirectory) = vbNullString Then DoesFileFolderExist = True
End Function

Function GetActualFolderName(StartOfPath As String, StartOfFuzzyFolder As String)
'sourced & modified from http://www.themssforum.com/ExcelProgramming/parent-folder/
'this loops through all subfolders in a named folder & gets the full name of _
the subfolder that starts with the "job number" (existence has been _
previously confirmed but w/o explicitly naming the folder. There may be _
a quicker/tidier way of doing this - but I haven't found it yet...
Dim oFSO As Object
Dim SubDirectory
Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO.GetFolder(StartOfPath)
    For Each SubDirectory In .SubFolders
        If UCase(Left(SubDirectory.Name, Len(StartOfFuzzyFolder))) = UCase(StartOfFuzzyFolder) Then
            GetActualFolderName = SubDirectory.Name
            Exit For
        End If
    Next SubDirectory
End With
'free memory
Set oFSO = Nothing
End Function

hth
Rob

[stevesunfold]

hi broro

unfortunately it doesnt work and returns the following error

macro ending b/c either :
1) no folder with the following job number exists
c:Documents and settings \HP_Owner\My documents\j4580*

[Richard Buttrey]

Steve,

That error you're getting doesn't appear to be caused by the modification broro (or I) made. It's comes as a result of an earlier bit of code which was presumably working OK before the additional folder stuff was added.

Can you confirm that you do have a .....J4580\Docs folder because the error message is suggesting you don't? Have you perhaps deleted that one now you've set up an alternative? If so try re-instating the original ...\Docs folder and seeing if that sorts it.

HTH