Create folder and save file within that folder

[josullivan601632]

Hi all

I have the following macro I run to save a file with filename derived from cells contents within the workbook and it works lovely

Of course, I have now developed the use of this file and would like to update this code so it creates a folder first and then saves the workbook in that folder, folder name to be same a workbook,
Sheets("Costing").Range("B1").Value & " " & Sheets("Costing").Range("A1").Value & " " & Sheets("Costing").Range("A2") as below (currently used for the workbook name).

I can't do it though ...can anybody help to update my existing code:

Sub SaveWorkbook()
Dim strTempFile As String
Dim strData As String
Dim spath As String

spath = Environ("USERPROFILE") & "\Newman Refrigeration Ltd\Newman Refrigeration Ltd - General\Contracting\2. Jobs\Current Jobs\ "
strData = Sheets("Costing").Range("B1").Value & " " & Sheets("Costing").Range("A1").Value & " " & Sheets("Costing").Range("A2").Value & ".xlsm"
strTempFile = spath & strData
MsgBox strData, , "This has been saved in the Current Jobs folder under filename:"

ActiveWorkbook.SaveCopyAs Filename:=strTempFile

End Sub

Would be really grateful, it is beyond me but would make a massive difference!!!!

Thank you.

Jo

 

[Wookiee]

It's hard to say exactly what's wrong without knowing what error you're getting, but I have an idea. Did you intend to leave a trailing space at the end of the sPath variable? It seemed that that might throw something off.

Might I suggest using either the f_Exists function or my ConfirmFolder macro? You can feed your file path to the f_Exists function to confirm whether the file path is correct and exists. To take it one step further, you can then create the folder if it does not exist using ConfirmFolder. Hope one of these helps!

Function f_Exists _
   (sFullPath As String) As Boolean
'>>Crafted by Ken Puls (www.excelguru.ca)


On Error GoTo EarlyExit

If Not Dir(sFullPath, vbDirectory) = vbNullString _
   Then f_Exists = True


EarlyExit:
On Error GoTo 0

End Function

Sub ConfirmFolder _
   (sFolder As String)
'Crafted  1 Aug 2018 by Jason B White


If Not f_Exists(sFolder) Then MkDir sFolder

End Sub

 

[josullivan601632]

Good morning

Thank you for your response. Apologies for not being clear, the example I showed is what I currently use to save the workbook and it works great. I haven't even attempted the create folder and then do this save...this is way beyond me!

Are you able to help? So I want to create a folder naming it the same way the current macro creates a filename, and then save the work in that folder.

 

[Wookiee]

Thank you for clarifying. I hope this macro achieves your desired results.

Sub JoSave()


'Declare Variables
Dim strFolder  As String
Dim strPath    As String

'Set Folder Path
strPath = Environ("USERPROFILE") & "\Newman Refrigeration Ltd\" & _
  "Newman Refrigeration Ltd - General\Contracting\2. Jobs\Current Jobs\ "

With Sheets("Costing")

  'Determine File Name From Cell Contents
  strFolder = strPath & _
    .Range("B1") & " " & .Range("A1") & " " & .Range("A2")

  'Create Folder
  On Error Resume Next
    MkDir strFolder
  On Error GoTo 0

End With

ActiveWorkbook.SaveAs _
  Filename:=strFolder, _
  FileFormat:=xlOpenXMLWorkbookMacroEnabled

End Sub

 

[josullivan601632]

Hi thank you for trying for me. Unfortunately I get a 400 error code so not sure what the problem is!

 

[Wookiee]

I still feel like that trailing space in the path is to blame. Please try this version (I also noticed I had forgotten to include the completion message earlier, so I have added that as well).

It worked for me (well, without all your file paths included, I just used the USERPROFILE folder), so I hope it works for you!

Sub JoSave2()


'Declare Variables
Dim strFolder  As String
Dim strPath    As String

'Set Folder Path
strPath = Environ("USERPROFILE") & "\Newman Refrigeration Ltd\" & _
  "Newman Refrigeration Ltd - General\Contracting\2. Jobs\Current Jobs\"

With Sheets("Costing")

  'Determine File Name From Cell Contents
  strFolder = strPath & _
    .Range("B1") & " " & .Range("A1") & " " & .Range("A2")

  'Create Folder
  On Error Resume Next
    MkDir strFolder
  On Error GoTo 0

End With

'Save File
ActiveWorkbook.SaveAs _
  Filename:=strFolder, _
  FileFormat:=xlOpenXMLWorkbookMacroEnabled

'Display Completion Message
MsgBox ActiveWorkbook.Name, , _
  "This has been saved in the Current Jobs folder as:"

End Sub

 

[josullivan601632]

Ahhh now I have noticed that there has been a beautiful folder created in the correct place
(Does still have the 400 error tho which is a bit weird)
Also, the folder is empty, so the macro I used before to save the workbook (and copy and pasted to show you) worked a treat I just don't know "join" both so the folder gets created and then the workbook gets saved in the folder. Nearly there tho, if you can spare the time to help!

 

[josullivan601632]

I just tried your last macro and it works lovely without the error code.
I just need to have the workbook saved to that folder now

 

[Wookiee]

I just tried your last macro and it works lovely without the error code.
I just need to have the workbook saved to that folder now

Okay, well progress is good! I now see where I failed to include the final folder in the path.

Here's hoping the third time's the charm!

Sub JoSave3()


'Declare Variables
Dim strFile    As String
Dim strFolder  As String
Dim strPath    As String

'Set Folder Path
strPath = Environ("USERPROFILE") & "\Newman Refrigeration Ltd\" & _
  "Newman Refrigeration Ltd - General\Contracting\2. Jobs\Current Jobs\"

With Sheets("Costing")

  'Determine File Name From Cell Contents
  strFile = .Range("B1") & " " & .Range("A1") & " " & .Range("A2")
  strFolder = strPath & strFile

  'Create Folder
  On Error Resume Next
    MkDir strFolder
  On Error GoTo 0

End With

'Save File
ActiveWorkbook.SaveAs _
  Filename:=strFolder & "\" & strFile, _
  FileFormat:=xlOpenXMLWorkbookMacroEnabled

'Display Completion Message
MsgBox ActiveWorkbook.Name, , _
  "This has been saved in the Current Jobs folder as:"

End Sub

 

[josullivan601632]

That's amazing, it works a treat.
Really appreciate you taking the time to help us, it's so clever (but so difficult for novices like me).
Have a great week