VBA to save to a folder searching for the first 5 digits of the folder name.

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
467
Office Version
  1. 365
Platform
  1. Windows
Hi
I wonder if anybody can help with this.
I have some code which will look at a cell value on my sheet (Which is a five-digit number), search in a directory open that folder and then open a subfolder within that folder & save the file.
This works just great if the parent folder & cell value are identical, but these parent folders will start with the 5 digit number then a space followed by some descriptive text.
Is there any way of searching just for the first 5 digits of a folder name?
Any help is always appreciated
VBA Code:
Sub Save() 'Sub Save()' this is the save code so it will save to the correct TNumber folder
 Dim CurrentSheet As Worksheet
 Dim WB As Workbook
 Set CurrentSheet = ActiveSheet
 A = Cells(4, 3).Value 'row & column T number
   'Application.DisplayAlerts = False

Set WB = ActiveWorkbook

   '     Changing drive letter
      ChDrive "W:\"
'     Changing directory
On Error GoTo InvalidDirectory
      ChDir "W:\1WIS LIVE\" & A & "\11. Router & Inspection Report"
'     Prompt for new file location
     mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub
'     Save
      ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
     ActiveWorkbook.Save

     CurrentSheet.Select
   Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub



InvalidDirectory:
       ChDir "W:\1WIS LIVE"
'     Prompt for new file location
     mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub

  '     Save
    ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
     ActiveWorkbook.Save
     CurrentSheet.Select
   Application.ScreenUpdating = True
    'Application.DisplayAlerts = True


End Sub
 
Dave
Apologies for bothering you again, but how do I incorporate my Error handler, it doesn’t seem to do anything. I need to default to ("W:\1WIS LIVE\" & Fl.Name), with
Application.GetSaveAsFilename box should there be any issues.

Code:
Sub Save() ' this will look at the first five digits of the folder name
Dim FSO As Object, Fl As Object, FlDr As Object
Dim Fl2 As Object, FlDr2 As Object, mySaveFile As String
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE")

On Error GoTo InvalidDirectory

For Each Fl In FlDr.subfolders
'match 1st 5 letters with folder name
If Left(ActiveSheet.Range("C4"), 5) = Left(Fl.Name, 5) Then
'set folder to found folder
Set FlDr2 = FSO.GetFolder("W:\1WIS LIVE\" & Fl.Name)
'loop folder to find if 11. Router & Inspection Report exists
For Each Fl2 In FlDr2.subfolders 'Files
If Fl2.Name = "11. Router & Inspection Report" Then
'create new file name
mySaveFile = "W:\1WIS LIVE\" & Fl.Name & "\" & Fl2.Name & "\" & CStr(ActiveSheet.Range("I4")) & ".xlsm"
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Exit Sub

End If
Next Fl2
End If
Next Fl
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing

InvalidDirectory:
       ChDir "W:\1WIS LIVE"
'     Prompt for new file location
     mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub

  '     Save
    ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
     ActiveWorkbook.Save
     CurrentSheet.Select

End Sub
 
Upvote 0

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
I would change it up a bit as follows:
Code:
Function SaveIt() As Boolean() ' this will look at the first five digits of the folder name
Dim FSO As Object, Fl As Object, FlDr As Object
Dim Fl2 As Object, FlDr2 As Object, mySaveFile As String
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE")
For Each Fl In FlDr.subfolders
'match 1st 5 letters with folder name
If Left(ActiveSheet.Range("C4"), 5) = Left(Fl.Name, 5) Then
'set folder to found folder
Set FlDr2 = FSO.GetFolder("W:\1WIS LIVE\" & Fl.Name)
'loop folder to find if 11. Router & Inspection Report exists
For Each Fl2 In FlDr2.subfolders 'Files
If Fl2.Name = "11. Router & Inspection Report" Then
'create new file name
On Error GoTo ErFix
mySaveFile = "W:\1WIS LIVE\" & Fl.Name & "\" & Fl2.Name & "\" & CStr(ActiveSheet.Range("I4")) & ".xlsm"
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
SaveIt = True
GoTo Below
End If
Next Fl2
End If
Next Fl
Below:
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
Exit Function

ErFix:
On Error GoTo 0
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
End Function
Then use this ( ie. Call RunSaveit)
Code:
Sub RunSaveIt()
Dim mySaveFile
If Not SaveIt Then
ChDir "W:\1WIS LIVE"
'     Prompt for new file location
mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub
  '     Save
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Save
CurrentSheet.Select
Else
MsgBox "File Saved!"
End If
End Sub
HTH. Dave
ps. using XL words like "save" to name subs will likely end up generating unexpected results.
 
Upvote 0
Thanks Dave, appreciate all your time.
Also thanks for the sub naming tip

I have tried the code you kindly provided for me, but have got something wrong, I have placed both pieces of code in the same module
I get an error when I run this code “can’t assign to array”
With this highlighted in the code “SaveIt =” part of the line “SaveIt = True”
Code:
Sub RunSaveIt()
Dim mySaveFile
If Not SaveIt Then
ChDir "W:\1WIS LIVE"
'     Prompt for new file location
mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
      If mySaveFile = False Then Exit Sub
  '     Save
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Save
CurrentSheet.Select
Else
MsgBox "File Saved!"
End If
End Sub


Function SaveIt() As Boolean() ' this will look at the first five digits of the folder name
Dim FSO As Object, Fl As Object, FlDr As Object
Dim Fl2 As Object, FlDr2 As Object, mySaveFile As String
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE")
For Each Fl In FlDr.subfolders
'match 1st 5 letters with folder name
If Left(ActiveSheet.Range("C4"), 5) = Left(Fl.Name, 5) Then
'set folder to found folder
Set FlDr2 = FSO.GetFolder("W:\1WIS LIVE\" & Fl.Name)
'loop folder to find if 11. Router & Inspection Report exists
For Each Fl2 In FlDr2.subfolders 'Files
If Fl2.Name = "11. Router & Inspection Report" Then
'create new file name
On Error GoTo ErFix
mySaveFile = "W:\1WIS LIVE\" & Fl.Name & "\" & Fl2.Name & "\" & CStr(ActiveSheet.Range("I4")) & ".xlsm"
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
SaveIt = True
GoTo Below
End If
Next Fl2
End If
Next Fl
Below:
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
Exit Function

ErFix:
On Error GoTo 0
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
End Function
 
Upvote 0
Whoops... my bad. This is wrong...
Code:
Function SaveIt() As Boolean()
Should be...
Code:
Function SaveIt As Boolean()
My apologies. Dave
 
Upvote 0
It doesn’t like that Dave.

Every time I change it to “Function SaveIt As Boolean()” it changes back to “Function SaveIt() As Boolean()”
 
Upvote 0
Dave thank you so much for your time, all working well except my error handler. When the code cannot save, it defaults to this pc “my documents”, instead of file path "W:\1WIS LIVE"
I have taken enough of your time so will try & resolve this myself by stepping through the code to see if I can see where it’s falling over.
If, however I cannot sort it would it be OK to request some more help

Gary
 
Upvote 0
OK Dave, got it working modified my error handler to
VBA Code:
ChDrive "W:\"
before 'Changing directory
VBA Code:
ChDir "W:\1WIS LIVE"
Thank you so much that is a really nice piece of code, something I could never have done. Here is the complete code with my amended error handler in full in case it helps anybody else.
Code:
Sub RunSaveIt()
Dim mySaveFile
If Not SaveIt Then
'Changing drive letter
ChDrive "W:\"
'Changing directory
ChDir "W:\1WIS LIVE"
'Prompt for new file location
       mySaveFile = Application.GetSaveAsFilename(Range("I4").Text & ".xlsm", "Microsoft Excel Workbook (*.xlsm), *.xlsm")
        If mySaveFile = False Then Exit Sub
            'Save
            ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        ActiveWorkbook.Save
    CurrentSheet.Select
Else
MsgBox "File Saved!"
End If
End Sub


Function SaveIt() As Boolean ' this will look at the first five digits of the folder name
Dim FSO As Object, Fl As Object, FlDr As Object
Dim Fl2 As Object, FlDr2 As Object, mySaveFile As String
Set FSO = CreateObject("scripting.filesystemobject")
Set FlDr = FSO.GetFolder("W:\1WIS LIVE")
For Each Fl In FlDr.subfolders
'match 1st 5 letters with folder name
If Left(ActiveSheet.Range("C4"), 5) = Left(Fl.Name, 5) Then
'set folder to found folder
Set FlDr2 = FSO.GetFolder("W:\1WIS LIVE\" & Fl.Name)
'loop folder to find if 11. Router & Inspection Report exists
For Each Fl2 In FlDr2.subfolders 'Files
If Fl2.Name = "11. Router & Inspection Report" Then
'create new file name
On Error GoTo ErFix
mySaveFile = "W:\1WIS LIVE\" & Fl.Name & "\" & Fl2.Name & "\" & CStr(ActiveSheet.Range("I4")) & ".xlsm"
ActiveWorkbook.SaveAs Filename:=mySaveFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
SaveIt = True
GoTo Below
End If
Next Fl2
End If
Next Fl
Below:
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
Exit Function

ErFix:
On Error GoTo 0
Set Fl2 = Nothing
Set Fl = Nothing
Set FlDr = Nothing
Set FSO = Nothing
End Function
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top