Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1232to1236
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@ Sepp: Druckbereich finetuning

@ Sepp: Druckbereich finetuning
Claudia
Hallo Sepp,
kannst Du mir bitte noch helfen.
Ich habe einen Kalender. Ab Zeile 3 in Spalte C steht das gesamte Jahr (01.01.2011 bis 31.12.2011).
Die Tabelle selbst geht von Spalte A bis Z.
Ich benötige zwei Druckmakros:
1 Monat auf eine Seite (also 12 Seiten)
2 Monate auf eine Seite (also 6 Seiten)
Die Ränder sind 0,5 - die oberen beiden Zeilen (1 + 2 ) sollen auf jeder Seite mitgedruckt werden.
Ich verzweifel. Eine Tabelle habe ich hochgeladen.

Die Datei https://www.herber.de/bbs/user/77025.xls wurde aus Datenschutzgründen gelöscht


Bitte so, dass ich die Spalte einfach ändern kann. Sonst muss ich Dich irgendwann wieder um RAt fragen.
Vielen lieben Dank!
Liebe Grüße
Claudia
AW: @ Sepp: Druckbereich finetuning
15.10.2011 17:09:56
Josef

Hallo Claudia,
probier mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub printCalendar(Optional ByVal MonthsPerPage = 1)
  Dim lngIndex As Long, lngCol As Long
  Dim vntRet As Variant
  Dim strPrintArea As String
  
  lngCol = 3 'Datumsspalte
  
  With Sheets("Tabelle1")
    .ResetAllPageBreaks
    For lngIndex = 1 To 12 Step MonthsPerPage
      vntRet = Application.Match(Clng(DateSerial(Year(.Cells(3, lngCol)), lngIndex + MonthsPerPage, 1)), .Columns(lngCol), 0)
      If IsNumeric(vntRet) Then
        .HPageBreaks.Add Before:=.Cells(vntRet, 1)
      End If
    Next
    strPrintArea = .Range("A1").CurrentRegion.Address
    With .PageSetup
      .PrintArea = strPrintArea
      .PrintTitleRows = "$1:$2"
      .PrintTitleColumns = ""
      .LeftMargin = Application.InchesToPoints(0.196850393700787)
      .RightMargin = Application.InchesToPoints(0.196850393700787)
      .TopMargin = Application.InchesToPoints(0.196850393700787)
      .BottomMargin = Application.InchesToPoints(0.196850393700787)
      .HeaderMargin = Application.InchesToPoints(0.511811023622047)
      .FooterMargin = Application.InchesToPoints(0.511811023622047)
      .Zoom = Choose(MonthsPerPage, 100, 95, 65, 50)
    End With
  End With
  
End Sub


Sub Print1()
  printCalendar 'ein Monat pro Seite
End Sub


Sub print2()
  printCalendar 2 'zwei Monate pro Seite
End Sub


Sub print3()
  printCalendar 3 'drei Monate pro Seite
End Sub



« Gruß Sepp »

Anzeige
AW: @ Sepp: Druckbereich finetuning
15.10.2011 17:39:50
Claudia
Hallo Sepp,
mag noch nicht so.
Bei Print 1 klappt es, allerdings sind nicht alle Spalten drauf.
Bei Print 2 + 3 kommt was ganz anderes raus.
Muss ich den Zoom vorgeben?
Liebe Grüße
Claudia
AW: @ Sepp: Druckbereich finetuning
15.10.2011 17:48:08
Josef

Hallo Claudia,
der Zoom wird bereits eingestellt.
Deine Tabelle entspricht aber schon dem von dir hochgeladenen Beispiel?

« Gruß Sepp »

Anzeige
Ja, nur gibt es Spalten bis einschl. Z.
15.10.2011 17:49:08
Claudia
und die 26 Spalten sollen alle ...
15.10.2011 17:55:26
Josef

... auf eine Seite gequetscht werden?

« Gruß Sepp »

AW: und die 26 Spalten sollen alle ...
15.10.2011 17:57:28
Claudia
Ja, die sind nicht so groß. Wichtig ist die Druckbegrenzung auf
einen Monat
oder
zwei Monate
Bei mir wird nix gequetscht. :-)
AW: und die 26 Spalten sollen alle ...
15.10.2011 18:04:28
Josef

Hallo Claudia,
also bei mir funzt es so wie gewünscht.
https://www.herber.de/bbs/user/77026.xls

« Gruß Sepp »

Anzeige
AW: und die 26 Spalten sollen alle ...
15.10.2011 18:25:36
Claudia
Hallo Sepp,
ja ich sehe es.
Kann es daran liegen, dass Du Hochformat und ich Querformat habe?
Wenn ja, ging das auch auf Querfomat?
Liebe Grüße
Claudia
AW: und die 26 Spalten sollen alle ...
15.10.2011 19:34:22
Josef

Hallo Claudia,
war kurz weg;-))
Probiere diesen Code.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub printCalendar(Optional ByVal MonthsPerPage = 1)
  Dim lngIndex As Long, lngCol As Long, lngZoom As Long
  Dim vntRet As Variant, lngView As Long
  Dim strPrintArea As String
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  lngView = ActiveWindow.View
  ActiveWindow.View = xlPageBreakPreview
  
  lngCol = 3 'Datumsspalte
  
  With Sheets("Tabelle1")
    .ResetAllPageBreaks
    For lngIndex = 1 To 12 Step MonthsPerPage
      vntRet = Application.Match(Clng(DateSerial(Year(.Cells(3, lngCol)), lngIndex + MonthsPerPage, 1)), .Columns(lngCol), 0)
      If IsNumeric(vntRet) Then
        .HPageBreaks.Add Before:=.Cells(vntRet, 1)
      End If
    Next
    strPrintArea = .Range("A1").CurrentRegion.Resize(, 26).Address
    With .PageSetup
      .PrintArea = strPrintArea
      .PrintTitleRows = "$1:$2"
      .PrintTitleColumns = ""
      .LeftMargin = Application.CentimetersToPoints(0.5)
      .RightMargin = Application.CentimetersToPoints(0.5)
      .TopMargin = Application.CentimetersToPoints(0.5)
      .BottomMargin = Application.CentimetersToPoints(0.5)
      .HeaderMargin = Application.CentimetersToPoints(1.5)
      .FooterMargin = Application.CentimetersToPoints(1.5)
      .Orientation = xlLandscape
      .Zoom = 100
      Do While (.Parent.HPageBreaks.Count > (12 / MonthsPerPage - 1) Or .Parent.VPageBreaks.Count > 0)
        .Zoom = .Zoom - 5
        .PaperSize = .PaperSize
        If .Zoom = 10 Then Exit Do
      Loop
    End With
    .PrintPreview
  End With
  
  ErrExit:
  ActiveWindow.View = lngView
  Application.ScreenUpdating = True
End Sub


Sub Print1()
  printCalendar 'ein Monat pro Seite
End Sub


Sub print2()
  printCalendar 2 'zwei Monate pro Seite
End Sub


Sub print3()
  printCalendar 3 'drei Monate pro Seite
End Sub



« Gruß Sepp »

Anzeige
AW: und die 26 Spalten sollen alle ...
15.10.2011 19:50:35
Claudia
Hallo Sepp,
ich habs gemerkt. :-) Dachte schon, Du wärst sauer wegen dem Mehraufwand.
Ich habe es schon ausprobiert. Funktioniert wieder einmal super!
Vielen lieben Dank!
Schönes WE (und bis zum nächsten Mal)
Claudia

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige