Save Each Worksheet to Individual PDF

[heroofgoodwi]

Hey Guys,

So I Currently have a piece of code I have been working on which lists through a variable cell and changes it from 1 to 34 then saves a copy of each individual page as a PDF. However I am having a few problems getting it to do exactly what I would like.



The edit I have been unable to make is to allow the user to select a final location to save the individual PDF's

Any help would be greatly appreciated, Code can be found below.


Sub saveCopies()
Dim x As Integer 'x = workstream list
Dim counter As Integer 'counter = counter for workstreams
Dim wb As Workbook 'define active workbook
Dim reportws As Worksheet ' set report ws
Dim controlws As Worksheet 'set control ws

Set wb = ActiveWorkbook 'activate workbook
Set reportws = Sheets("REPORT") 'define report sheet
Set controlws = Sheets("Control Sheet") ' define control sheet
counter = 0 'set counter to zero
For x = 1 To 34 ' one for each workstream
Application.ScreenUpdating = False 'turn off screen updating to speed up code
counter = counter + 1 ' increase counter by 1
controlws.Select 'select control ws
Cells(1, 10).Value = counter 'Assign control cell for workstream the value of counter
reportws.Select 'Select report sheet

Application.ScreenUpdating = True 'turn on screen updating so snapshot of report can be taken

'COPY WORKSHEET AS A PDF AND THEN NAME IT THE RELEVANT WORKSTREAM

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("G4").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

Next x 'Next workstream

msgbox "Reports have successfully been produced"
End Sub

[p45cal]

What's in G4?
Perhaps something along the following lines:
Sub saveCopies()
Dim x As Integer 'x = workstream list
Dim counter As Integer 'counter = counter for workstreams
Dim wb As Workbook 'define active workbook
Dim reportws As Worksheet ' set report ws
Dim controlws As Worksheet 'set control ws

Set wb = ActiveWorkbook 'activate workbook
Set reportws = Sheets("REPORT") 'define report sheet
Set controlws = Sheets("Control Sheet") ' define control sheet
counter = 0 'set counter to zero
For x = 1 To 34 ' one for each workstream
Application.ScreenUpdating = False 'turn off screen updating to speed up code
counter = counter + 1 ' increase counter by 1
controlws.Select 'select control ws
Cells(1, 10).Value = counter 'Assign control cell for workstream the value of counter
reportws.Select 'Select report sheet

Application.ScreenUpdating = True 'turn on screen updating so snapshot of report can be taken

'COPY WORKSHEET AS A PDF AND THEN NAME IT THE RELEVANT WORKSTREAM
DestFolder = SelectAFolder
If Not IsEmpty(DestFolder) Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DestFolder & Application.PathSeparator & Range("G4").Value, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "Skipped that one"
End If
Next x 'Next workstream

MsgBox "Reports have successfully been produced"
End Sub

Function SelectAFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = ??
.Title = "Select a Folder to save to"
.AllowMultiSelect = False
If .Show = -1 Then SelectAFolder = .SelectedItems(1)
End With
End Function

[heroofgoodwi]

Well that is very clever thank you.

However is it possible to only have the save location prompt for the first file and then save all the rest to the same location so that the user does not have to select the individual file each time?

[p45cal]

However is it possible to only have the save location prompt for the first file and then save all the rest to the same location so that the user does not have to select the individual file each time?
This is exasperating. you specifically asked for:

to allow the user to select a final location to save the individual PDF's
Sub saveCopies()
Dim x As Integer 'x = workstream list
Dim counter As Integer 'counter = counter for workstreams
Dim wb As Workbook 'define active workbook
Dim reportws As Worksheet ' set report ws
Dim controlws As Worksheet 'set control ws

Set wb = ActiveWorkbook 'activate workbook
Set reportws = Sheets("REPORT") 'define report sheet
Set controlws = Sheets("Control Sheet") ' define control sheet
DestFolder = SelectAFolder
If Not IsEmpty(DestFolder) Then
counter = 0 'set counter to zero
For x = 1 To 34 ' one for each workstream
Application.ScreenUpdating = False 'turn off screen updating to speed up code
counter = counter + 1 ' increase counter by 1
controlws.Select 'select control ws
Cells(1, 10).Value = counter 'Assign control cell for workstream the value of counter
reportws.Select 'Select report sheet
Application.ScreenUpdating = True 'turn on screen updating so snapshot of report can be taken
'COPY WORKSHEET AS A PDF AND THEN NAME IT THE RELEVANT WORKSTREAM
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DestFolder & Application.PathSeparator & Range("G4").Value, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Next x 'Next workstream
MsgBox "Reports have successfully been produced"
Else
MsgBox "Aborted"
End If
End Sub

Function SelectAFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = ??
.Title = "Select a Folder to save to"
.AllowMultiSelect = False
If .Show = -1 Then SelectAFolder = .SelectedItems(1)
End With
End Function

[heroofgoodwi]

Apologies for the confusion.

Just had some coffee and immediately realised that by placing
DestFolder = SelectAFolder solved the problem.

I just wanted to say thank you for the help. I immediately tried to edit the comment and was hit with the waiting period between posting when I realised how daft I had been

[p45cal]

The problem now will be changing the file name each time; if G4 doesn't change, you'll only end up with one file.

[heroofgoodwi]

Okay finished example shown below.

Cell ("G4") is a dynamically changing title cell so the end results should all get produced. Just wanted to thank you again for the help and apologies for not being clearer the first time around.


Sub saveCopies()
Dim x As Integer 'x = workstream list
Dim counter As Integer 'counter = counter for workstreams
Dim wb As Workbook 'define active workbook
Dim reportws As Worksheet ' set report ws
Dim controlws As Worksheet 'set control ws

Set wb = ActiveWorkbook 'activate workbook
Set reportws = Sheets("REPORT") 'define report sheet
Set controlws = Sheets("Control Sheet") ' define control sheet
counter = 0 'set counter to zero
DestFolder = SelectAFolder
For x = 1 To 34 ' one for each workstream
Application.ScreenUpdating = False 'turn off screen updating to speed up code
counter = counter + 1 ' increase counter by 1
Application.StatusBar = "Producing report " & counter 'Set up status bar to show progress
controlws.Select 'select control ws
Cells(1, 10).Value = counter 'Assign control cell for workstream the value of counter
reportws.Select 'Select report sheet

Application.ScreenUpdating = True 'turn on screen updating so snapshot of report can be taken

'COPY WORKSHEET AS A PDF AND THEN NAME IT THE RELEVANT WORKSTREAM ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DestFolder & Application.PathSeparator & Range("G4").Value, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next x 'Next workstream
Application.StatusBar = False
msgbox "Reports have successfully been produced" 'clear status bar
End Sub

sub function to select folder location. Linked to Dynamic title cell

Function SelectAFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = ??
.Title = "Select a Folder to save to"
.AllowMultiSelect = False
If .Show = -1 Then SelectAFolder = .SelectedItems(1)
End With
End Function