Abbrechen funkt. nicht
23.05.2007 20:42:21
Heinz
Habe unteres Makro zum erstellen eines neuen Tab.Blatt bekommen.
Nur funkt.das abrechen nicht.
Wenn ich auf Abbrechen klicke wird trozdem ein neues Blatt eingefügt.
Könnte mir Bitte jemand helfen ?
Danke & Gruß Heinz
Private Sub CommandButton2_Click()
' Anfang *******************************************************************************
' Erstellt ein beliebiges Jahresblatt und benennt es in der Form 'WoMat_JJJJ'
' Um auf diesem Blatt Eintagungen vornehmen zu können, muß das bestehende
' Tabellenblatt 'WoMat' umbenannt bzw. gelöscht werden. Das neu erzeugte
' Blatt dann in 'WoMat' umbenennen.
' Beliebiges WoMat - Jahr erstellen
'Sub Neues_woMat()
Dim Vorgabe%, Jahr, n%, x%
Dim Datum As Date
Vorgabe = Year(Now) + 1
' Abfrage des Jahres
Jahr = Application.InputBox("Geben Sie das Jahr für ein neues WoMat-Blatt ein.", _
"Jahr eingeben", Vorgabe, , , , 1)
' ganzes Blatt kopieren und umbenennen
Sheets("WoMat").Copy After:=Sheets(2)
Sheets("WoMat (2)").Name = "WoMat_" & CStr(Jahr)
' Sonntag ermitteln
n = 0
Do
Datum = DateSerial(Jahr, 1, 1 - n)
n = n + 1
Loop Until Weekday(Datum) = vbSunday
Dim Jj%, Mm%, Dd%
Jj = Year(Datum): Mm = Month(Datum): Dd = Day(Datum)
With Sheets("WoMat_" & CStr(Jahr))
' eventuellen Blattschutz aufheben
On Error Resume Next
.Unprotect
' Datum und Tage eintragen
x = 0
For n = 5 To 1981 Step 38 ' Für ganzes Jahr - 53 Wochen
.Cells(n + 0, 1) = "So"
.Cells(n + 1, 1) = DateSerial(Jj, Mm, Dd + x)
.Cells(n + 5, 1) = "Mo"
.Cells(n + 6, 1) = DateSerial(Jj, Mm, Dd + x + 1)
.Cells(n + 10, 1) = "Di"
.Cells(n + 11, 1) = DateSerial(Jj, Mm, Dd + x + 2)
.Cells(n + 15, 1) = "Mi"
.Cells(n + 16, 1) = DateSerial(Jj, Mm, Dd + x + 3)
.Cells(n + 20, 1) = "Do"
.Cells(n + 21, 1) = DateSerial(Jj, Mm, Dd + x + 4)
.Cells(n + 25, 1) = "Fr"
.Cells(n + 26, 1) = DateSerial(Jj, Mm, Dd + x + 5)
.Cells(n + 30, 1) = "Sa"
.Cells(n + 31, 1) = DateSerial(Jj, Mm, Dd + x + 6)
x = x + 7
Next n
End With
End Sub