AW: Tabelle und PDF - Druck unterschiedlich?
20.06.2020 08:19:39
STeve
Guten Morgen Onur...
.hast natürlich recht ;-). Habe jetzt die Code - Zeile auf:
.PrintArea = Range(Cells(1, 1), Cells(Beamter, 37)).Address ''''neu mit 20.6.20
geändert.
Jetzt springt er nicht mehr auf Fehler.....aaaaaber natürlich bleibt mein Grundproblem bestehen!!!
Habe hier eine xlsx Datei hochgeladen
..Druck-Code ist hier unten extra da ich keine xlsm Datei hochladen kann.
Nehme mal stark an dass bei Umwandlung in PDF immer eine gewisse leichte Verzehrung der Zeilenhöhe und Spaltenbreite bleibt sodass die Ausdrucke dann niemals identisch sind!!!!!!
https://www.herber.de/bbs/user/138443.xlsx
Sub DF_Druck()
With Application 'hier alle Bremsklötze mal ausgeschalten
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Application.DisplayAlerts = False
On Error GoTo Fehler 'Fängt einen Fehler ab
Sheets("Komplettplan").Delete ' löscht ein allenfalls bereits vorhandene AUSDRUCK Tabelle
Application.DisplayAlerts = True
Fehler: Resume Next 'springt bei Fehler gleich in den nächsten Befehl
Dim x As Integer
Dim y As Integer
With Worksheets("datenliste").Activate
ActiveSheet.Range("D100").End(xlUp).Offset(0, -2).Select 'schaut in Tab. Datenliste _
nach wieviele Leute eingetragen sind und geht
' dann auf die linke Zeile _
und lest den WErt aus.
x = Selection.Value 'Wert - Zeilennummer wird ausgelesen
End With
Worksheets("VORLAGE").Range("A4: AK" & x + 3).Copy ' letzter Mitarbeiter + 3 Zeilen wird _
kopiert
Dim ws As Worksheet
Set ws = Sheets.Add
ws.Name = "Komplettplan" ' neues Tabellenblat wird generiert
With Worksheets("Komplettplan").Range("A1")
.PasteSpecial xlPasteValues ' fügt Werte ein
.PasteSpecial xlPasteFormats ' fügt Formate ein
.Range("A1").Value = "x=Feiertag"
.Range("A5").Value = "Termine/Vorgaben:"
.Range("A1,A4,A10,A13:Aj14,A2,A3,D4:Aj4").Font.Bold = True
.Range("A1").Font.Size = 10
.Range("A2").Font.Size = 14
.Range("A3").Font.Size = 28
.Range("A3").Font.Underline = False
.Range("D2").Font.Size = 48
Dim monat As String ' Überschrift Plan mit Monat und Jahr wird erstellt
monat = ActiveSheet.Cells(2, 37)
monat = Format(Cells(2, 37), "MMMM")
.Range("D2").Value = "Plan " & monat & " " & .Range("AK3").Value
.Range("A4: AK" & x).Font.Size = 18
.Range("AK:AK").Columns.AutoFit
.Range("A:A").Columns.AutoFit
Dim Bereich As Range
Set Bereich = ActiveSheet.UsedRange ' zeilenhöhe wird eingestellt
Bereich.RowHeight = 34
ActiveSheet.Range(Cells(1, 1), Cells(1, 37)).RowHeight = 14 'die erste Zeile mit x und _
copywright bei wird klein gemacht
Dim vonobendie9zellenübernameleeren As Integer ' löscht von oben über jedem Namen die _
9Zelleninhalte
For vonobendie9zellenübernameleeren = 15 To x Step 8
Range(Cells(vonobendie9zellenübernameleeren, 1), Cells(vonobendie9zellenübernameleeren + 2, _
3)).Clear
Next vonobendie9zellenübernameleeren
Dim Beamter As Integer ' färbt jeden zweiten MA leicht grau ein
For Beamter = 15 To x Step 16
Range(Cells(Beamter, 1), Cells(Beamter + 6, 36)).Interior.Color = RGB(219, 219, 219)
Next Beamter
Dim Spalte As Range ' färbt Sa und So ein
For Each Spalte In Sheets("Komplettplan").Range(Cells(4, 4), Cells(x, 36)).Columns
Select Case Weekday(Spalte.Cells(11), 2)
Case 6: Spalte.Interior.Color = RGB(204, 255, 255) ' Farbe des Samstages
Case 7: Spalte.Interior.Color = RGB(255, 204, 153) 'Farbe des Sonntages
End Select
Next
For Each Spalte In Sheets("Komplettplan").Range(Cells(1, 4), Cells(x, 36)).Columns ' _
sucht das x oder X in Zeile ein und färbt den Feiertag ein
Select Case Left(Spalte.Cells(1), 36)
Case "x", "X": Spalte.Interior.Color = RGB(255, 204, 153)
End Select
Next
Dim ausblenden As Integer 'blendet von oben bis zeile 42 jede 7 _
zeile aus wenn nicht Datum drinnen steht
For ausblenden = 22 To x Step 8
If Cells(ausblenden, 1).Value = "" Then
Rows(ausblenden).Hidden = True
End If
Next ausblenden
'hier die Formatierung für die MA dicker Strich einarbeiten start mit zeile 21 - _
Unterstrich
For Beamter = 21 To x Step 8
Range(Cells(Beamter, 1), Cells(Beamter, 3)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Next Beamter
With ActiveSheet.PageSetup
' .PrintArea = Range("A:AK" & Cells(x, 30).End(xlUp)) 'springt immer auf Fehler - _
geht aber ?
.PrintArea = Range(Cells(1, 1), Cells(Beamter, 37)).Address ''''neu mit 20.6.20
.PrintTitleRows = "$2:$14" 'das fixiert die Kopfzeile
.PaperSize = xlPaperA3
.Orientation = xlLandscape
.FitToPagesTall = False
.FitToPagesWide = 1
.Zoom = False
.CenterFooter = "&18 &B & copyright ae+se" & "&18 &B& Seite: &P von &N" & "&18 _
&B copyright ae+se"
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
End With
ActiveWindow.View = xlPageBreakPreview 'zeigt die Umbruchvorschau an
Dim lngZ As Long
Dim strSpalte As String
strSpalte = "A"
ActiveSheet.ResetAllPageBreaks 'Alle Seitenumbrüche der aktiven Seite zurü _
cksetzen
For lngZ = 54 To Range(strSpalte & "65000").End(xlUp).Row Step 40 'ab Zeile 53 ' _
Seitenumbruch je 5 MA setzen
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range(strSpalte & lngZ)
Next
End With
With Application 'Bresmklötze wieder rein
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
With ActiveSheet 'macht zuerst am Desktop eine pdf Speicherung
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ$("USERPROFILE") & _
"\Desktop\DPL " & monat & " " & .Range("AK3").Value & " " & "Komplettplan " & " " _
& Format(Now, "DD.MM.YYYY, hh.mm") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
.PrintPreview ' dann Druckvorschau
End With
End Sub
Besten Dank für Tipps/Infos usw.
lg STeve