Amend vba to add file name on save as

[Pete]

see screen print
Hi Experts

Just need a slight amendment to the current vba (kevin) has so far provided me with this excellent solution.

But i need a extra step to be added to the current code. (see snippet)

1. Need the macro to add the current name i.e page 1 = Argentina to the file name box as shown in the screen print and then move onto page 2 = Australia etc.....

2. And at the same time print the a copy to the default printer.


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Dim FilePath As String

If SaveAsUI Then
FilePath = Application.GetSaveAsFilename(ThisWorkbook.Path & "\" & ActiveSheet.Name, "Text File (*.pdf), *.pdf")
If Not FilePath = "False" Then
ThisWorkbook.SaveAs FilePath
End If
Cancel = True
End If

End Sub

[Demosthine]

Good Afternoon.

If I'm understanding you right, whenever the User selects Save As, you want them to choose the "standard" filename and then the script goes through a loop and saves each worksheet separately using that filename, but adding the sheetname to the end of it. Is that correct?

i.e.
User chooses File Name "Regional_Update"
- Script saves Worksheet "Argentina" to file "Regional_Update - Argentina.xls"
- Script saves Worksheet "Bolivia" to file "Regional_Update - Bolivia.xls"
- etc.

Are you only wanting that one ActiveSheet to be saved to the new file?

Scott

[Pete]

User chooses File Name "Regional_Update"
- Script saves Worksheet "Argentina" to file "Regional_Update - Argentina.xls"
- Script saves Worksheet "Bolivia" to file "Regional_Update - Bolivia.xls"
- etc.

yes to your comment

[Demosthine]

Good Morning.



Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strFilePath As String
Dim shtCurrentSheet As Worksheet
Dim wbkNewBook As Workbook
Dim shtNewSheet As Worksheet

' If the User has selected File | Save As...
If SaveAsUI Then
' Get the Path and Filename that the User wants to save the new file to.
strFilePath = Application.GetSaveAsFilename( _
ThisWorkbook.Name, "Excel 2000-2003 (*.xls), *.xls")

' Disable DisplayAlerts so that the User will not be asked if they want to
' delete the new pages.
' Disable ScreenUpdating so that the User will not see the new Workbooks
' open and be changed.
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

' Delete the File Extension so that we can add the Sheet Name to the end
' of the Filename.
strFilePath = Replace(strFilePath, ".xls", "")

' If the User did not click Cancel, continue processing.
If strFilePath <> "False" Then
' Since we want to save each Worksheet Individually, we process them
' separately.
For Each shtCurrentSheet In ThisWorkbook.Worksheets
' Create a new Workbook to save the current Worksheet to.
Set wbkNewBook = Application.Workbooks.Add

' Copy the current Worksheet to the new Workbook.
shtCurrentSheet.Copy wbkNewBook.Worksheets(1)

' Delete all of the Default Worksheets in the new Workbook.
For Each shtNewSheet In wbkNewBook.Worksheets
' If the Worksheet Name in the new Workbook does not match
' the Worksheet we are copying from the old Workbook, we
' delete it.
If shtNewSheet.Name <> shtCurrentSheet.Name Then
shtNewSheet.Delete
End If
Next shtNewSheet

' We want to print the entire new Workbook to the Default Printer.
wbkNewBook.PrintOut

' Close the new Workbook, saving it to the Path the User chose above
' with the Filename the User chose, but adding the Worksheet's name.
wbkNewBook.Close True, strFilePath & " - " & shtCurrentSheet.Name & ".xls"

' Process the next Worksheet in our primary Workbook.
Next shtCurrentSheet
End If

' Re-enable DisplayAlerts and ScreenUpdating so the User can continue as normal.
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

' Cancel this Workbook's Save As function since we've already saved the Worksheets.
Cancel = True
End If
End Sub



Scott

[Norie]

Scott

Do you realise you can copy a worksheet and create a new workbook like this?

shtCurrentSheet.Copy

[Demosthine]

Good Afternoon Norie.

No, I wasn't aware of that. It appears that when you do that, it automatically activates the new Workbook, so you would use ActiveWorkbook.Close to finish the process.

I really appreciate the info.
Scott

[Pete]

Thanks Scott,

Excellent code works prefectly,..........just one question how would you amend to apply the same to MicroSoft Projects Application

[Demosthine]

Good Morning Pete.

That one I'm not sure about. I haven't installed Project in ages because the last few tiems I tried to use it, it was less than great for the work I was doing. I quickly found MsWord was a much better choice at the time. I'm sure it's come a long way since then, but old habits die hard.

I'm glad that worked, though. Let me know if there's anything else you need, MsProject exluded :-).

P.S. If you aren't aware, when your thread is solved, use Thread Tools from the top of Post #1 to mark it is "Solved".

Scott