Listeneintrag Uhrzeit zum drucken verändern

[Arni49]

Code:

Private Sub cmdPrint_Click()
 Dim zeLB As Long, spLB As Long
 Dim zeTB As Long, spTB As Long
 Dim allesDrucken As Boolean
 
    ' Zellen leeren
   
    Range("Druckvorlage!A2:P1000") = ""
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = "&P&""Fett""&36Behandlungs-Terminplan"
        .RightHeader = "" & Chr(10) & ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.236220472440945)
        .RightMargin = Application.InchesToPoints(0.236220472440945)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.354330708661417)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintSheetEnd
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = 70
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
        End With
      
   
    '--- Drucker auswählen
    Application.Dialogs(xlDialogPrinterSetup).Show
   
    '-- Prüfen, ob alles gedruckt werden muss
    For zeLB = 0 To lstResponse.ListCount - 1
        allesDrucken = allesDrucken Or lstResponse.Selected(zeLB)
    Next
    zeTB = 1
    '--- selektierte Listboxeinträge in Zellen schreiben
    For zeLB = 0 To lstResponse.ListCount - 1
        If lstResponse.Selected(zeLB) Or Not allesDrucken Then
            zeTB = zeTB + 1
            For spLB = 1 To lstResponse.ColumnCount - 1
                Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = lstResponse.List(zeLB, spLB)
          
            Next
        End If
    Next
       
    Sheets("Druckvorlage").Visible = True
   
    ' Drucke Tabellenblatt
    Worksheets("Druckvorlage").PrintOut
    Sheets("Druckvorlage").Visible = True
   
 End Sub
  

Hallo,
das drucken der Listeneinträge funktioniert.
Jetzt müsste ich noch vor dem Druck die  Uhrzeiten anhand der Behandlungsarten zum drucken wie folgt verändern.
Behandlungsarten:
KG, Bad, LYM30, LYM45, LYM60, Massage, Fußpflege, Podologie, Fußreflex, CMD, VM, BM = 20 Minuten später als eingetragen
PM40, PVM40, CMDP40, PKG40 = 20 Minuten früher als eingetragen
Hat jemand eine Idee wie das umgesetzt werden kann ?

[Kuwer]

Hallo,

so vielleicht:

Private Sub cmdPrint_Click()
Dim zeLB As Long, spLB As Long
Dim zeTB As Long, spTB As Long
Dim allesDrucken As Boolean

   ' Zellen leeren
   Range("Druckvorlage!A2:P1000") = ""
    
   Application.PrintCommunication = False
   With ActiveSheet.PageSetup
       .PrintTitleRows = "$1:$1"
       .PrintTitleColumns = ""
   End With
   Application.PrintCommunication = True
   ActiveSheet.PageSetup.PrintArea = ""
   Application.PrintCommunication = False
   With ActiveSheet.PageSetup
       .PrintTitleRows = "$1:$1"
       .PrintTitleColumns = ""
       .LeftHeader = ""
       .CenterHeader = "&P&""Fett""&36Behandlungs-Terminplan"
       .RightHeader = "" & Chr(10) & ""
       .LeftFooter = ""
       .CenterFooter = ""
       .RightFooter = ""
       .LeftMargin = Application.InchesToPoints(0.236220472440945)
       .RightMargin = Application.InchesToPoints(0.236220472440945)
       .TopMargin = Application.InchesToPoints(0.748031496062992)
       .BottomMargin = Application.InchesToPoints(0.354330708661417)
       .HeaderMargin = Application.InchesToPoints(0.31496062992126)
       .FooterMargin = Application.InchesToPoints(0.31496062992126)
       .PrintHeadings = False
       .PrintGridlines = False
       .PrintComments = xlPrintSheetEnd
       .PrintQuality = 600
       .CenterHorizontally = False
       .CenterVertically = False
       .Orientation = xlPortrait
       .Draft = False
       .PaperSize = 70
       .FirstPageNumber = xlAutomatic
       .Order = xlDownThenOver
       .BlackAndWhite = False
       .Zoom = False
       .FitToPagesWide = 1
       .FitToPagesTall = False
       .PrintErrors = xlPrintErrorsDisplayed
       .OddAndEvenPagesHeaderFooter = False
       .DifferentFirstPageHeaderFooter = False
       .ScaleWithDocHeaderFooter = True
       .AlignMarginsHeaderFooter = True
       .EvenPage.LeftHeader.Text = ""
       .EvenPage.CenterHeader.Text = ""
       .EvenPage.RightHeader.Text = ""
       .EvenPage.LeftFooter.Text = ""
       .EvenPage.CenterFooter.Text = ""
       .EvenPage.RightFooter.Text = ""
       .FirstPage.LeftHeader.Text = ""
       .FirstPage.CenterHeader.Text = ""
       .FirstPage.RightHeader.Text = ""
       .FirstPage.LeftFooter.Text = ""
       .FirstPage.CenterFooter.Text = ""
       .FirstPage.RightFooter.Text = ""
       End With
      
   '--- Drucker auswählen
   Application.Dialogs(xlDialogPrinterSetup).Show
   
   '-- Prüfen, ob alles gedruckt werden muss
   For zeLB = 0 To lstResponse.ListCount - 1
       allesDrucken = allesDrucken Or lstResponse.Selected(zeLB)
   Next
   
   zeTB = 1
   '--- selektierte Listboxeinträge in Zellen schreiben
   For zeLB = 0 To lstResponse.ListCount - 1
       If lstResponse.Selected(zeLB) Or Not allesDrucken Then
           zeTB = zeTB + 1
           Select Case lstResponse.List(zeLB, 3)
               Case "KG", "Bad", "LYM30", "LYM45", "LYM60", "Massage", "Fußpflege", "Podologie", "Fußreflex", "CMD", "VM", "BM"
                   Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = Format(CDate(lstResponse.List(zeLB, 1)) + TimeSerial(0, 20, 0), "hh:nn")
               Case "PM40", "PVM40", "CMDP40", "PKG40"
                   Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = Format(CDate(lstResponse.List(zeLB, 1)) - TimeSerial(0, 20, 0), "hh:nn")
               Case Else
                   Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = lstResponse.List(zeLB, 1)
           End Select
           For spLB = 2 To lstResponse.ColumnCount - 1
               Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = lstResponse.List(zeLB, spLB)
           Next
       End If
   Next
       
   ' Drucke Tabellenblatt
   Sheets("Druckvorlage").Visible = True
   Worksheets("Druckvorlage").PrintOut
   Sheets("Druckvorlage").Visible = False
End Sub

Gruß Uwe

[Arni49]

Hallo Uwe,

leider funktioniert es so nicht! Der Ausdruck hat noch die gleiche Zeit.
Gruß Arnold

[Kuwer]

Hallo Arnold,

leider funktioniert es so nicht! Der Ausdruck hat noch die gleiche Zeit.

und nun!? Bilderrätsel finde ich hier nicht so prickelnd.

Gruß Uwe

[Arni49]

Hallo,

habe folgende Änderung gemacht:
zeLB, 3 auf 4 geändert.

Code:

zeTB = 1
   '--- selektierte Listboxeinträge in Zellen schreiben
   For zeLB = 0 To lstResponse.ListCount - 1
       If lstResponse.Selected(zeLB) Or Not allesDrucken Then
           zeTB = zeTB + 1
           Select Case lstResponse.List(zeLB, 4)
              Case "kg", "Bad", "lym30", "lym45", "lym60", "massage", "Fußpflege", "Podologie", "Fußreflex", "CMD", "VM", "BM"
                  Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = Format(CDate(lstResponse.List(zeLB, 2)) + TimeSerial(0, 20, 0), "hh:nn")
              Case "PM40", "PVM40", "CMDP40", "PKG40"
                  Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = Format(CDate(lstResponse.List(zeLB, 2)) - TimeSerial(0, 20, 0), "hh:nn")
              Case Else
              Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = lstResponse.List(zeLB, 2)
          End Select
           For spLB = 1 To lstResponse.ColumnCount - 1
               Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = lstResponse.List(zeLB, spLB) 'zeTB Zeile, spTB Spalte

[attachment=20441]
In der Liste zum Drucken fängt er aber erst in der 2. Zeile an die Zeiten zu ändern.

[Arni49]

Hallo,

kann den niemand helfen?

[schauan]

Hallöchen,

wenn Du Dir die verschiedenen Codes anschaust - auch Deinen zuerst geposteten, solltest Du feststellen können, wieso erst Zeile 2 geändert wird.

Du setzt vor der Schleife die Variable für die Zeile auf 1 und erhöhst sie um 1 vor der ersten Änderung in der Schleife.

[Arni49]

Hallo,
Habe es mir nochmal angesehen, jetzt klappt es.

Jetzt möchte ich noch via VBA unten in der Fußzeile folgende Texte platzieren:

Rechts:

[b]Bitte beachten Sie:[/b]

Terminabsage nur in dringenden

Fällen, spätestens jedoch 24 Stunden

vor der Behandlung.

Nicht rechtzeitig abgesagte Termine

werden privat in Rechnung gestellt.

Links auf gleicher Zeilenhöhe:

Hinweis für Dauerpatienten:
Um Behandlungspausen zu vermeiden
sowie Termin- und Therapeutenwünsche
zu berücksichtigen, bitte Folgetermine
8 Wochen im Voraus vereinbaren!
Mittagpause 12 – 14 Uhr

Habe es mit .Leftfooter und Rightfooter probiert, das Funktioniert aber wegen der vielen Zeichen nicht.

.LeftFooter = "&""Calibri""&8&BBitte beachten Sie:&B" & Chr(10) & "Terminabsage nur in dringenden" & Chr(10) & "Fällen, spätestens jedoch 24 Stunden" & Chr(10) & "vor der Behandlung." & Chr(10) & "Nicht rechtzeitig abgesagte Termine" & Chr(10) & "werden privat in Rechnung gestellt."

.RightFooter = "&""Calibri""&8&BHinweis für Dauerpatienten:&B" & Chr(10) & " ……. mehr geht nicht.


Gibt es noch eine andere Möglichkeit die Texte Unten als Fußzeile auf jeden Ausdruck zu bekommen ?

[schauan]

Hallöchen,

ich glaube, Du musst entweder die Texte radikal und auf das Wesentliche einkürzen, z.B.

Terminabsagen spätestens 24 Stunden
vor der Behandlung.
Nicht rechtzeitig abgesagte Termine
werden privat in Rechnung gestellt.

Hinweis für Dauerpatienten:
bitte Folgetermine 8 Wochen im
Voraus vereinbaren!
Mittagpause 12 – 14 Uhr

--> ohne Fett Formatierung

oder normale Tabellenzeilen benutzen Die Zeilen könntest Du beim Ausdruck mit VBA einfügen, ich nehme an, Du hast auch mal mehrere Blätter zu drucken. Eventuell reicht aber auch die Angabe auf dem ersten Blatt eines Ausdrucks, dann kannst Du das fest machen.


Eventuell schreibst Du die Mittagspause in die Mitte - die gilt doch nicht nur für Dauerpatienten

[Frogger1986]

Du könntest statt Zellen zu füllen, einfach eine Textbox einfügen..