Meedere versies van één sheet naar één PDF

Artemiss · 9 sep 2013

Beste VBA'ers,

Ik ben nu al een hele tijd aan het prutsen, maar kom er toch net niet.
Ik heb in een bestand een sheet "Dagrapport" waarop je de datum kunt selecteren, waarna de gegevens van die dag zichtbaar worden, middels een Worksheet_Change.

Nu wil ik een macro maken die alle dagrapporten van één week in één PDF opslaat.
Ik heb de volgende code, de verschillende onderdelen al op verschillende manieren binnen of buiten de tweede For gezet, maar ik krijg steeds maar één dagrapport in het PDF-bestand. In de huidige setting, het één na laatste dagrapport, eerder de laatste, maar ik weet niet precies meer wat er toen anders was.
Daarnaast loopt hij nooit helemaal door, hij blijft hangen in het stukje

Do
DoEvents
Loop Until Dir(PDFpad & PDFnaam) = PDFnaam

terwijl het bestand wel opgeslagen is.

Er zit een dubbele For in omdat hij naast dat hij door verschillende datums moet lopen, hij ook door verschillende werknummers moet lopen. Dus eerst alle datums in de gekozen week van het eerste werknummer en daarvan één pdf, vervolgens van het tweede werknummer een aparte PDF, enz.

Hopelijk kan iemand mij vertellen, waarom de code niet goed werkt.

Code:

Sub Dagrapporten_opslaan1PDF()

Dim pdfjob As Object
Dim PDFnaam As String
Dim PDFpad As String
Dim bRestart As Boolean
Dim werknummer As String
Dim weeknummer As String
Dim counter As Long
Dim counter2 As Long
Dim DRcount As Long
Dim d As Variant

    On Error GoTo EarlyExit

    Do
        bRestart = False
        Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
        If pdfjob.cStart("/NoProcessingAtStartup") = False Then
            'PDF Creator is already running.  Kill the existing process
            Shell "taskkill /f /im PDFCreator.exe", vbHide
            DoEvents
            Set pdfjob = Nothing
            bRestart = True
        End If
    Loop Until bRestart = False
    
    
        BeveiligingOpheffen
        'Sheets("Dagrapport").PivotTables("WerkPerWeek").PivotFields("Week").ClearAllFilters                                                 'selectie weeknummer
        Sheets("Dagrapport").PivotTables("WerkPerWeek").PivotFields("Week").CurrentPage = Sheets("Dagrapport").Range("Z18").Value
    
        counter = Sheets("Dagrapport").Range("AC65536").End(xlUp).Row                                                                   'selectie werknummer
        For Each x In Range("AC4:AC" & counter)
            BeveiligingOpheffen
    
            Application.EnableEvents = False
            Range("Y3").Value = x.Value
            
            'Sheets("Dagrapport").PivotTables("DatumsWerkWeek").PivotFields("Week").ClearAllFilters
            Sheets("Dagrapport").PivotTables("DatumsWerkWeek").PivotFields("Week").CurrentPage = Sheets("Dagrapport").Range("Z18").Value
            'Sheets("Dagrapport").PivotTables("DatumsWerkWeek").PivotFields("Werknummer").ClearAllFilters
            Sheets("Dagrapport").PivotTables("DatumsWerkWeek").PivotFields("Werknummer").CurrentPage = x.Value
                                
                counter2 = Sheets("Dagrapport").Range("AF65536").End(xlUp).Row                                                              'selectie datum
                For Each d In Range("AF5:AF" & counter2)
                    
                    'BeveiligingOpheffen
                    
                    If Dir(ThisWorkbook.Path & "\" & werknummer, vbDirectory) = Empty Then MkDir ThisWorkbook.Path & "\" & werknummer
                    If Dir(ThisWorkbook.Path & "\" & werknummer & "\Dagrapporten", vbDirectory) = Empty Then MkDir ThisWorkbook.Path & "\" & werknummer & "\Dagrapporten"
                                    
                    DRcount = Sheets("Dagrapport").Range("AI4").Value
                    werknummer = Sheets("Dagrapport").Range("Y3").Value
                    weeknummer = Sheets("Dagrapport").Range("Z18").Value
                    PDFpad = ThisWorkbook.Path & "\" & werknummer & "\Dagrapporten\"
                    PDFnaam = "DR-" & werknummer & " ; " & weeknummer & ".pdf"
                    
                    With pdfjob
                        .cOption("UseAutosave") = 1
                        .cOption("UseAutosaveDirectory") = 1
                        .cOption("AutosaveDirectory") = PDFpad
                        .cOption("AutosaveFilename") = PDFnaam
                        .cOption("AutosaveFormat") = 0 ' 0 = PDF
                        .cClearCache
                    End With
                    
                    If Dir(PDFpad & PDFnaam) = PDFnaam Then Kill (PDFpad & PDFnaam)
                                    
                    Application.EnableEvents = True
                    Sheets("Dagrapport").Range("A35").Value = d.Value
                    Application.EnableEvents = False
                                        
                    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, ActivePrinter:="PDFCreator"
                                                    
                Next
                
                    Do Until pdfjob.cCountOfPrintjobs = 1 'Or BytLoops = 8
                        'MsgBox (pdfjob.cCountOfPrintjobs)
                        DoEvents
                        'BytLoops = BytLoops + 1
                    Loop
                    
                    With pdfjob
                        .cCombineAll
                        .cPrinterStop = False
                    End With
                        
                    Do
                        DoEvents
                    Loop Until Dir(PDFpad & PDFnaam) = PDFnaam
                                        
        Next
        
BeveiligingInstellen

Cleanup:
    'Release objects and terminate PDFCreator
    Set pdfjob = Nothing
    Shell "taskkill /f /im PDFCreator.exe", vbHide
    On Error GoTo 0
    Application.ScreenUpdating = True
    Exit Sub
    
EarlyExit:
    'Inform user of error, and go to cleanup section
    MsgBox "There was an error encountered.  PDFCreator has" & vbCrLf & _
           "has been terminated.  Please try again.", _
           vbCritical + vbOKOnly, "Error"
    Resume Cleanup
    


End Sub

Artemiss · 22 sep 2013

Beste VBA'ers,

Ik weet niet zo goed of mijn vraag niet duidelijk genoeg was of dat ik misschien iets tegen de regels heb gedaan waardoor ik geen reactie heb gekregen, maar aangezien ik het echt nodig heb, ben ik zelf nog verder gegaan met puzzelen en heb ondertussen het eerste level werkend gekregen, middels onderstaande code.
Ik loop nu echter nog tegen één probleem aan, het kan voorkomen dat er in een bepaalde week maar 1 dagrapport is en in dat geval werkt .cCombineAll niet. Kan iemand mij misschien vertellen waar ik de rode tekst door zou kunnen/moeten vervangen om het werkend te krijgen? Ik zou echt heel dankbaar zijn....

Code:

Sub Dagrapporten_opslaan1PDF()

Dim pdfjob As Object
Dim PDFnaam As String
Dim PDFpad As String
Dim bRestart As Boolean
Dim werknummer As String
Dim weeknummer As String
Dim counter As Long
Dim counter2 As Long
Dim DRcount As Long
Dim d As Variant

    DRcount = Sheets("Dagrap").Range("AI4").Value
    werknummer = Sheets("Dagrap").Range("Y3").Value
    weeknummer = Sheets("Dagrap").Range("Z18").Value
    PDFpad = ThisWorkbook.Path & "\" & werknummer & "\Dagrapporten\"
    PDFnaam = "DR-" & werknummer & " ; " & weeknummer & ".pdf"
    
    BeveiligingOpheffen

    Sheets("Dagrap").PivotTables("WerkPerWeek").PivotFields("Week").ClearAllFilters                                                 'selectie weeknummer
    Sheets("Dagrap").PivotTables("WerkPerWeek").PivotFields("Week").CurrentPage = Sheets("Dagrap").Range("Z18").Value
    Sheets("Dagrap").PivotTables("DatumsWerkWeek").PivotFields("Week").ClearAllFilters
    Sheets("Dagrap").PivotTables("DatumsWerkWeek").PivotFields("Week").CurrentPage = Sheets("Dagrap").Range("Z18").Value
    
    If Dir(ThisWorkbook.Path & "\" & werknummer, vbDirectory) = Empty Then MkDir ThisWorkbook.Path & "\" & werknummer
    If Dir(ThisWorkbook.Path & "\" & werknummer & "\Dagrapporten", vbDirectory) = Empty Then MkDir ThisWorkbook.Path & "\" & werknummer & "\Dagrapporten"

    'Activate error handling and turn off screen updates
    On Error GoTo EarlyExit
    Application.ScreenUpdating = False

    Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")

    'Check if PDFCreator is already running and attempt to kill the process if so
    Do
        bRestart = False
        Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
        If pdfjob.cStart("/NoProcessingAtStartup") = False Then
            'PDF Creator is already running.  Kill the existing process
            Shell "taskkill /f /im PDFCreator.exe", vbHide
            DoEvents
            Set pdfjob = Nothing
            bRestart = True
        End If
    Loop Until bRestart = False

    'Assign settings for PDF job
    With pdfjob
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = PDFpad
        .cOption("AutosaveFilename") = PDFnaam
        .cOption("AutosaveFormat") = 0     '0 = PDF
        .cClearCache
    End With
    
        counter2 = Sheets("Dagrap").Range("AF65536").End(xlUp).Row                                                              'selectie datum
        For Each d In Range("AF5:AF" & counter2)
            
            Application.EnableEvents = True
            Sheets("Dagrap").Range("A35").Value = d.Value
            Application.EnableEvents = False
            
            ActiveWindow.SelectedSheets.PrintOut copies:=1, ActivePrinter:="PDFCreator"
    
        Next

    'Wait until all print jobs have entered the print queue
    Do Until pdfjob.cCountOfPrintjobs = DRcount
        'MsgBox (cCountOfPrintjobs)
        DoEvents
    Loop

    'Combine all PDFs into a single file and stop the printer
    If DRcount > 1 Then
        With pdfjob
            [COLOR="#FF0000"].cCombineAll[/COLOR]
            .cPrinterStop = False
        End With
    Else
        With pdfjob
            [COLOR="#FF0000"]'HIER MOET NOG IETS KOMEN WAARDOOR HIJ EEN ENKELE SHEET OPSLAAT[/COLOR]  
           .cPrinterStop = False
        End With
    End If

    'Wait until the file shows up before closing PDF Creator
    Do
        DoEvents
    Loop Until Dir(PDFpad & PDFnaam) = PDFnaam

Cleanup:
    'Release objects and terminate PDFCreator
    Set pdfjob = Nothing
    Shell "taskkill /f /im PDFCreator.exe", vbHide
    On Error GoTo 0
    Application.ScreenUpdating = True
    Exit Sub

EarlyExit:
    'Inform user of error, and go to cleanup section
    MsgBox "There was an error encountered.  PDFCreator has" & vbCrLf & _
           "has been terminated.  Please try again.", _
           vbCritical + vbOKOnly, "Error"
    Resume Cleanup

End Sub

HSV · 22 sep 2013

Meestal als er geen bestand is toegevoegd wordt er minder of niet gereageerd Frauke.

Artemiss · 23 sep 2013

Beste Harry,

Bedankt voor de reactie, maar het bestand is te groot, bevat vertrouwelijke informatie en er wordt het nodige voor betaald, dus vind ik niet dat ik dit zomaar op internet kan gaan uploaden.
Ik heb ook mijn tweede vraag ondertussen zelf opgelost, dus zal ik deze vraag afsluiten.

Meedere versies van één sheet naar één PDF

Artemiss

Gebruiker

Artemiss

Gebruiker

HSV

Inventaris

Artemiss

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy