AW: Codeerweiterung
19.11.2008 08:37:00
Werner
Hallo Jürgen,
meinst Du so?
Sub TerminZumDrucken(Art As Boolean)
'Art = True heißt "Termine drucken"; Art = False heißt "Versäumte drucken"
Dim Datum1 As Date, z As Long, i As Long
Dim col As Long
Dim ntage
Dim ws As Worksheet
Set ws = Worksheets("Nachschulung")
Application.DisplayAlerts = False
'Keine Excel-Rückfrage beim späteren Löschen des neu erzeugten Tabellenblatts zum Drucken
Application.ScreenUpdating = False ' Das neue Tabellenblatt wird nicht angezeigt.
Sheets.Add 'neues Tabellenbblat zur Druckerausgabe
ActiveSheet.Name = "Termine zum Drucken"
With ws
z = 2 ' Deine Bezugnahme auf die Namen für die Schleife
i = 2 ' neu für die Erstellung einer Liste in "Termine zum Drucken"
'Die Überschriften der neuen Liste (fett)
Cells(1, 1) = "Terminart"
Cells(1, 2) = "Name"
Cells(1, 3) = "Datum"
If Art Then
Cells(1, 4) = "Tage ab heute"
ActiveSheet.PageSetup.CenterHeader = "Termine" ' Kopfzeile
Else
Cells(1, 4) = "Tage seit Termin"
ActiveSheet.PageSetup.CenterHeader = "Versäumte Termine" ' Kopfzeile
End If
'******************************eingefügt! *****************************
'********** und Bereiche alle um 1 erweitert, also bis Spalte 5 *******
Cells(1, 5) = "angemeldet am:"
'****************************** bis hier! *****************************
Range(Cells(1, 1), Cells(1, 5)).Font.Bold = True
Datum1 = Format(Now(), "dd.mm.yyyy")
'Das hier ist im wesentlichen die ehemalige MsgBox-Anweisung
Do While .Cells(z, 3) <> ""
For col = 4 To 14 'D bis N
If IsDate(.Cells(z, col)) Then
ntage = .Cells(z, col) - Datum1: If Not Art Then ntage = -ntage
If ntage >= 1 And ntage <= 90 Then
Cells(i, 1) = .Cells(1, col)
Cells(i, 2) = .Cells(z, 2) & " " & .Cells(z, 3)
Cells(i, 3) = Format(.Cells(z, col), "dd.mm.yyyy")
Cells(i, 4) = ntage
'******************************eingefügt! *****************************
Cells(i, 5) = .Cells(z, 13)
'****************************** bis hier! *****************************
i = i + 1
End If
End If
Next col
z = z + 1
Loop
End With
Cells.Select: Selection.Columns.AutoFit 'Alle Spalten mit optimaler Breite
Range("A1", ActiveSheet.Cells.Find(What:="*", After:=[A1], _
SearchDirection:=xlPrevious).Address).Select 'Markieren aller Zellen mit Eintrag
If Art Then
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal 'Die Tabelle nach "Tage bis heute" sortieren ("D2")
Else
Selection.Sort Key1:=Range("D2"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal 'Die Tabelle nach "Tage seit Termin" sortieren ("D2")
End If
'******************************eingefügt! *****************************
With ActiveSheet.PageSetup
.RightFooter = "Druckdatum: &D"
End With
'****************************** bis hier! *****************************
Application.Dialogs(xlDialogPrint).Show 'Das Drucken-Fenster erscheint.
'Nach dem Ausdruck wird die Code-erzeugte Tabelle wieder gelöscht.
Sheets("Termine zum Drucken").Select: ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub
Gruß
werner