AW: Makrocode: Filter abfragen und drucken
20.08.2013 15:24:16
fcs
Hallo Hendrik,
hier ein Makro, dass für die Ausgabe verschiedene Möglichkeiten hat:
1. Speichern als PDF für jede Kunden-Nr. (funktioniert ab Excel 2007)
2. Ausgabe als Postscript-Datei via FreePDF,
hier können natürlich auch andere Drucker eingestellt werden.
Die PS-Dateien können dann mit FreePDF, Acrobat-Distiller etc. weiter zu PDF-Dateien verarbeitet werden.
3. Ausgabe auf dem aktuell aktiven Drucker
Gruß
Franz
'Makro in einem allgemeinen Modul
'Erstellt unter Excel 2010 - Windows XP
Sub Drucken_KundenDiagramme()
Dim wksPivot As Worksheet
Dim pvTab As PivotTable, pvField As PivotField
Dim intKunde As Integer, rngKundenNr As Range
Dim objCollection As New Collection
Dim strPrinter As String, strDatei As String, strPfad As String
Dim bolPdf As Boolean
'Formate für Kundennummer und akteueles Datum/Zeit im PDF/PS-Dateinamen
Const cstrFormatKdnNr As String = "000000"
Const cstrFormatDatZeit As String = "YYYYMMDD hh_mm_ss"
On Error GoTo Fehler
strPfad = ActiveWorkbook.Path 'Verzeichnis für PDF bzw. Postscript-Dateien
strPrinter = Application.ActivePrinter
If MsgBox("zu jeder Kunden-Nr. eine PDF-Datei mit Diagrammen erstellen?" _
& vbLf & "(funktioniert erst ab Excel 2007!)", _
vbQuestion + vbYesNo, "Diagramme in PDF") = vbYes Then
bolPdf = True
Else
If MsgBox("Diagramme zu Kunden-Nrn. auf Drucker """ & strPrinter & """ drucken?", _
vbQuestion + vbOKCancel, "Diagramme drucken") = vbCancel Then Exit Sub
End If
Set wksPivot = ActiveWorkbook.Worksheets("Grafiken Lieferanten")
With ActiveWorkbook.Worksheets("Daten")
'Kunden-Nummern auslesen aus Spalte C ohne doppelte
For Each rngKundenNr In .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
objCollection.Add rngKundenNr.Value, rngKundenNr.Text
Next rngKundenNr
End With
wksPivot.Activate
Range("A1").Select
'für jeden Kunden die Pivottabellenberichte im Blatt "Grafiken Lieferanten" _
aktualisieren und drucken
For intKunde = 1 To objCollection.Count
'Pivotbericht(e) zu Kunden-Nr. aktualisieren
Application.ScreenUpdating = False
For Each pvTab In wksPivot.PivotTables
Set pvField = pvTab.PageFields("Kunden Nr.")
pvField.CurrentPage = Val(objCollection.Item(intKunde))
pvTab.RefreshTable
Next pvTab
Application.ScreenUpdating = True
If bolPdf = True Then
'Tabellenblatt als PDF-Datei speichern
strDatei = strPfad & "\Diagramm_" _
& Format(Val(objCollection.Item(intKunde)), cstrFormatKdnNr) _
& "-" & Format(Now, cstrFormatDatZeit) & ".pdf"
wksPivot.ExportAsFixedFormat Type:=0, Filename:= _
strDatei, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'Type:=0 = xlTypePDF
Else
If InStr(1, strPrinter, "FreePDF") > 0 Then
'Postscriptdatei erzeugen für Bearbeitung mit FreePDF-Join
strDatei = strPfad & "\Diagramm_" _
& Format(Val(objCollection.Item(intKunde)), cstrFormatKdnNr) _
& "-" & Format(Now, cstrFormatDatZeit) & ".ps"
wksPivot.PrintOut preview:=False, prtofilename:=strDatei
Else
'Ausgabe auf aktivem Drucker
wksPivot.PrintOut preview:=True 'für Produktionsbetrieb auf False setzen
End If
'Testzeile - später löschen/auskommentieren
If MsgBox("Nächstes Diagramm drucken?", vbQuestion + vbOKCancel, _
"Test-Anzeige - Diagramme drucken") = vbCancel Then Exit For
End If
Next intKunde
If bolPdf = True Then
MsgBox "Erstellte PDF-Dateien im Verzeichnis " & ActiveWorkbook.Path, _
vbOKOnly, "Fertig"
Else
If InStr(1, strPrinter, "FreePDF") > 0 Then
MsgBox "Postscript-Dateien erzeugt im Verzeichnis " & ActiveWorkbook.Path, _
vbOKOnly, "Fertig"
Else
MsgBox "Diagramm gedruckt auf " & strPrinter, vbOKOnly, "Fertig"
End If
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case 457 'doppelter Wert bei Collection.Add
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, "Makro: Drucken_KundenDiagramme"
End Select
End With
Application.ScreenUpdating = True
'Variablen aufräumen
Set wksPivot = Nothing
Set pvTab = Nothing: Set pvField = Nothing
Set rngKundenNr = Nothing
Set objCollection = Nothing
End Sub