VBA code pdf maken van meerdere sheets

[petropatrick]

Goedenmorgen,

ik heb een vraagje ik ben nu al een tijdje bezig om mijn rapport compleet te maken.
ik heb diverse knoppen gemaakt met daaronder een macro of vba code die ik met behulp van dit forum heb gemaakt.
Nu zit ik met een probleempje ik heb er een knop bij gemaakt die van de sheets die op dat moment in de onderbalk staan 1 pdf moet maken maar hij maakt van alle sheets aparte pdfjes.
hoe kan ik dat veranderen?
en mijn tweede vraag is:hoe kan ik met de knop opslaan als die ik ook gemaakt heb de file opslaan in een vaste map?

de code voor het opslaan als 1 pdf:

Sub Copy_Every_Sheet_To_PDF()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook
'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName
'Publish every visible worksheet with data
For Each sh In Sourcewb.Worksheets
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 And sh.UsedRange.Cells.Count > 1 Then
'Publish worksheet to pdf
On Error Resume Next
sh.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FolderName _
& "\" & sh.Name & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
On Error GoTo 0
End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

 

[OctaFish]

Zou je de code willen opmaken met de CODE knop? Dit is zo niet echt leesbaar

 

[petropatrick]

Heb ik het zo goed gedaan.

Sub Copy_Every_Sheet_To_PDF()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
     With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
     'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook
     'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
     'Publish every visible worksheet with data
    For Each sh In Sourcewb.Worksheets
         'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 And sh.UsedRange.Cells.Count > 1 Then
            'Publish worksheet to pdf
            On Error Resume Next
            sh.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=FolderName _
                            & "\" & sh.Name & ".pdf", _
                              Quality:=xlQualityStandard, _
                              IncludeDocProperties:=True, _
                              IgnorePrintAreas:=False, _
                              OpenAfterPublish:=False
            On Error GoTo 0
         End If
GoToNextSheet:
    Next sh
     MsgBox "You can find the files in " & FolderName
     With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
 End Sub

 

[OctaFish]

Da's inderdaad zoals het er uit moet zien :thumb:. Was handiger geweest als je dat in je oorspronkelijke vraag had aangepast, want daar staat nu nog steeds die meter tekst .
Je hebt (vermoed ik) je code bij Ron de Bruin 'geleend', en daar de variant gepakt die alle losse sheets mailt. Hij heeft ook een variant die het complete werkboek doet.
Overigens snap ik niet helemaal wat je bedoelt met:

... ik heb er een knop bij gemaakt die van de sheets die op dat moment in de onderbalk staan 1 pdf moet maken

Ben erg benieuwd wat een 'onderbalk' is

 

[petropatrick]

Dat is die balk met al de sheets die open staan de "Tabbladen"