Druckbereich per VBA

[Bernie]

Hallo zusammen,

komme irgendwie nicht weiter mit einem Makro.

Und zwar:
Wenn Zelle F40 mehr als "", dann drucke den Druckbereich von B1:Z41
Wenn Zelle F40 und F80 mehr als "", dann drucke den Druckbereich von B1:Z81
Wenn Zelle F40, F80, F120 mehr als "", dann drucke den Druckbereich von B1:Z121
Wenn Zelle F40, F80, F120 und F160 mehr als "", dann drucke den Druckbereich von B1:Z1611

Ich hoffe, dass ich mich klar ausgedrückt habe und bedanke mich schon mal im Voraus!!!

Geändert: Hatte vergessen zu erwähnen, dass in allen F-Zellen Formeln hinterlegt sind!!!

[pefeu]

Hallo Bernie,

ich würde es so versuchen

Code:

Option Explicit

Sub Druckbereich()

   ActiveSheet.PageSetup.PrintArea = ""
  
   If ActiveSheet.Range("F40").Value <> "" And _
      ActiveSheet.Range("F80").Value <> "" And _
      ActiveSheet.Range("F120").Value <> "" And _
      ActiveSheet.Range("F160").Value <> "" Then
      ActiveSheet.PageSetup.PrintArea = "$B$1:$Z$1611"
   ElseIf ActiveSheet.Range("F40").Value <> "" And _
      ActiveSheet.Range("F80").Value <> "" And _
      ActiveSheet.Range("F120").Value <> "" Then
      ActiveSheet.PageSetup.PrintArea = "$B$1:$Z$121"
   ElseIf ActiveSheet.Range("F40").Value <> "" And _
      ActiveSheet.Range("F80").Value <> "" Then
      ActiveSheet.PageSetup.PrintArea = "$B$1:$Z$81"
   ElseIf ActiveSheet.Range("F40").Value <> "" Then
      ActiveSheet.PageSetup.PrintArea = "$B$1:$Z$41"
   End If
    
End Sub

Gruß Peter

[atilla]

Hallo Bernie,

müssen alle Zellen auf nicht leer geprüft werden oder reicht es, wenn z.B F160 nicht leer dann den Bereich "$B$1:$Z$1611" drucken?

Damit würde der Code etwas kürzer ausfallen.

[Bernie]

Hallo Atilla,

schön mal wieder von Dir zu hören. War gerade am testen von Peters Vorschlag und hab noch Probleme mit dem Druckbereich.

Ja, du hast recht, wenn lediglich die einzelne F-Zelle, obwohl mit Formel hinterlegt, kein berechnenden Wert hat.

Es sollte auch der jeweilige Druckbereich Seite1= A2:Z41, Seite2=A2:Z81 usw. berücksichtigt werden. D.h. jeder Seite (4 gesamt) umfasst 40 Zeilen.

[Bernie]

Hallo Peter,

Danke für deine schnelle Hilfe.

Hab dein Vorschlag auf Druckbereich angepasst und die ersten beiden Seiten sind optimal, die dritte Seite übernimmt von der vierten Seite die erste Zeile mit auf Seite drei.

Bin noch am tüfteln.

[atilla]

Hallo Bernie,

da Du im letzten Beitrag andere Bereiche nennst als im ersten, habe ich mal die Bereiche aus dem ersten Beitrag genommen. Das Prinzip solltest Du aber anhand des Codes erkennen und für Dich anpassen können.

Code:

Sub test()
   Dim i As Long, j As Long
   Dim arr1, arr2
  
   arr1 = Array("$F160", "F120", "F80", "F40")
   arr2 = Array("$B$1:$Z$1611", "B1:Z121", "B1:Z81", "B1:Z41")
   For i = LBound(arr1) To UBound(arr1)
      If Range(arr1(i)) <> "" Then
         ActiveSheet.PageSetup.PrintArea = arr2(i)
         Exit For
      End If
   Next i
  
   ActiveSheet.ResetAllPageBreaks
   For j = 41 To Range(arr2(i)).Rows.Count Step 41
      ActiveSheet.HPageBreaks.Add Cells(j, 1)
   Next j

End Sub

[Bernie]

Hallo Atilla,

die letzten Zelldaten waren die Richtigen.
Allerdings wird die Skalierung bzw. die Seitenumbrüche entfernt, so dass ich keine richtige Druckseite habe, verschiebt sich alles.

Also Bereich der Druckseite ist von A2:Z41 + jeweils 40 Zeile je Druckseite, Skalierung hatte ich auf 93% und hatte auch einen Seitenumbruch eingefügt.

Folgenden Code habe ich an deinen gehängt...

Code:

sDruckerAktuell = Application.ActivePrinter
   'Application.ActivePrinter = "PDFCreator auf Ne00:"
   'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    ChDir "C:\Users\Bernd Kiehl\Downloads"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\Bernd Kiehl\Downloads\Dienstplan_Kiehl.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
   Application.ActivePrinter = sDruckerAktuell
End Sub

Da dein Code die von mir per Menü eingestellten Formatierungen für den Druck übern Haufen wirft.

Könntest du mir das ändern?

[atilla]

Hallo Bernie,

dann lösch mal diesen Teil:

Code:

ActiveSheet.ResetAllPageBreaks
   For j = 41 To Range(arr2(i)).Rows.Count Step 41
      ActiveSheet.HPageBreaks.Add Cells(j, 1)
   Next j

[Bernie]

Hallo Atilla,

ja, jetzt passte es! Danke dir recht♥lich