Statt Druck bestimmter Zellen - Erstellen PDF-Date
15.05.2018 17:23:50
Steven
ich nutze einen Code der bestens zum Ausdruck funktioniert. Dabei wird in einer Spalte nach Werten gesucht, wenn vorhanden wird diese Zeile gedruckt, klappt bestens. Ich möchte folgende Zeile ersetzen:
ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken
mit:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & ".NAME" & Format(Date, "YY.MM.DD.") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Das funktioniert leider nur für das erste Blatt beim pdf-Datei erstellen.
Da muss wohl noch eine For - Next Funktion rein, um alle Blätter zu erstellen?
Hier der Code:
Sub DruckEinzeln()
Dim lngZ As Long, lngLZ As Long
Dim Quelle As Worksheet, Ziel As Worksheet
'Mitteilung = Worksheets("BLATT").Range("B5").Value
Application.ScreenUpdating = False
'Application.PrintCommunication = False
With ActiveSheet.Select
Range("L31:M31").Select
Selection.EntireRow.Hidden = True
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$34"
.PrintTitleColumns = ""
End With
With ActiveSheet
.Unprotect "pass"
With ActiveSheet.PageSetup
.LeftHeader = Empty
.LeftFooter = Empty
.CenterHeader = Empty
.CenterFooter = Empty
.RightHeader = Empty
.RightFooter = Empty
.LeftMargin = Application.InchesToPoints(0.984252) 'Linker Rand
.RightMargin = Application.InchesToPoints(0.984252) 'Rechter Rand
.TopMargin = Application.InchesToPoints(0.6) 'Oberer Rand
.BottomMargin = Application.InchesToPoints(0.6) 'Unterer Rand
.HeaderMargin = Application.InchesToPoints(0) 'Kopfzeile
.FooterMargin = Application.InchesToPoints(0) 'Fußzeile
.LeftHeader = Empty
.RightHeader = "&6" & "File: " & ThisWorkbook.Name '"Druckdatum: " & Format(Date, " _
_
_
_
dd.mm.yyyy")
.LeftFooter = ""
End With
'.Range("H34:Q34").AutoFilter Field:=10, Criteria1:=""
'.PrintOut
'.Range("H34:Q34").AutoFilter Field:=10
.Protect "pass"
End With
'Application.PrintCommunication = True
lngLZ = Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile der Spalte J ermitteln
If MsgBox("Sollen die ZEILEN EINZELN gedruckt werden ?", _
vbYesNo + vbQuestion) = vbYes Then
Rows("35:" & lngLZ).AutoFilter Field:=10, Criteria1:=""
For lngZ = 35 To 250 'Alle Zeilen ab Zeile 35 bis 250
Rows("35:" & lngLZ).Hidden = True 'Zuerst ALLE Zeilen ab Zeile 35 ausblenden
If Cells(lngZ, 10) > 0 Then 'Zellen in Spalte "J" >0
Rows(lngZ).Hidden = False 'nur aktuelle Zeile einblenden
'ActiveSheet.PrintOut 'Aktuelles Blatt ausdrucken *******SOLL ERSETZT WERDEN****** _
_
_
_
*************** NEU STATT DRUCKEN ******************
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & ".BLATT" & Format(Date, "YY.MM.DD.") & Range("I18") & _
_
_
_
".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
*************** NEU STATT DRUCKEN ******************
End If
Next
End If
Rows("35:" & lngLZ).AutoFilter Field:=10
Rows("35:" & lngLZ).Hidden = False 'ALLE Zeilen ab Zeile 35 wieder einblenden
With ActiveSheet.Select
Range("L31:M31").Select
Selection.EntireRow.Hidden = False
End With
Application.ScreenUpdating = True
End Sub
Hat jemand dazu eine Idee? Diesmal habe ich das nicht woanders angefragt, war dumm von mir bei meinem ersten Posting.
Grüße aus Thüringen, Steven