VBA - Popup Window to Set Save Path for Macro

[muzikman69]

Essentially the code below cycles through the worksheets in the excel file and saves them to a specific folder.


Question 1:
How do I get the code below to show up in a sub "Code" box within this post? Rather than just have it in the body of the thread.


Question 2:
In the code below I can hard code where the individual worksheets will be saved.... however I am trying to make this a bit more user friendly and potentially allow for a pop-up for the user to choose the path all worksheets will be saved to.

Does anyone know to set a variable (Eg. strSavePath) via a popup or something of the sorts?


strSavePath = "N:\Finaserv\Graeme\Monthly Reports\Test\Individual Reports\"



Thanks for any help,
Cheers,
Graeme,

=================================================================



Option Explicit
Sub CreateWorkbooks()
'Creates an individual workbook for each worksheet in the active workbook.
Dim sht As Object 'Could be chart, worksheet, Excel 4.0 macro,etc.
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim strSavePath As String
Dim SavePath As String
Dim screenUpdateState As Variant
Dim statusBarState As Variant
Dim eventsState As Variant
Dim calcState As Variant

On Error GoTo ErrorHandler
' Turn off some Excel functionality so your code runs faster
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

' Application.ScreenUpdating = False 'Don't show any screen movement
strSavePath = "N:\Finaserv\Graeme\Monthly Reports\Test\Individual Reports\" 'Change this to suit your needs
' Copy Worksheet
Set wbSource = ActiveWorkbook
For Each sht In wbSource.Sheets ' this will save the second and third sheets and so on
' you change this to sheet names (e.g. "Sheet1","Sheet2",etc.)
sht.Copy
Set wbDest = ActiveWorkbook

' Save file in original folder, but as xls file format
SavePath = strSavePath & sht.Name & " " & Format(DateSerial(Year(Now), Month(Now) - 1, 1), "mmmm yy") & ".xlsx"
wbDest.SaveAs Filename:=SavePath, FileFormat:=51, CreateBackup:=False
wbDest.Close 'Remove this if you don't want each book closed after saving.
Next
' Turn Excel functionality back on
With Application
.DisplayStatusBar = statusBarState
.Calculation = calcState
.EnableEvents = eventsState
.ScreenUpdating = screenUpdateState
End With
Exit Sub
ErrorHandler: 'Just in case something hideous happens
MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
' Turn Excel functionality back on
With Application
.DisplayStatusBar = statusBarState
.Calculation = calcState
.EnableEvents = eventsState
.ScreenUpdating = screenUpdateState
End With
End Sub
</quote>

 

[mikerickson]

1) Two wrap your code, you could either type [ c o d e ] (no spaces) before and [ / c o d e ] after the code. OR select all of the code and press the # icon above the message entry box.

2) Have you looked at Application.GetSaveAsFilename? It returns a string, but does not save the file.

Dim filePath as String
filePath = Application.GetSaveAsFilename

If filePath = "False" Then
    MsgBox "cancel pressed'
Else
    MsgBox "File path set to " & fileName
End If

 

[muzikman69]

Thanks for both of those,


The Application.GetSaveAsFilename should work fine for my purposes.



Cheers,
Graeme,