Wenn Datum kleiner nicht hochzählen.
18.11.2007 17:08:00
Heinz
Der untere Code besagt wenn das heutige Monat "November" in Zelle F1, und man möchte nun eine neue Liste für "Dezember" erstellen dann Meldung "Sie dürfen erst ab Dezember 2007 ein neues Blatt erstellen"
Es hat den Grund das man nicht schon im voraus für mehrere Monate die Stundenlisten erstellen kann.
Man dürfte erst ab 1.Dezember eine neue Liste erstellen dürfen.
In Zelle A6 stimmt der Code er bleibt stehen,damit man nicht schon im November eine Liste für Dezember erstellen kann.
Aber in Zelle F1 wird trotzdem immer um ein Monat hochgezählt, sobald ich auf "Neues Monat anlegen klicke.
Habe zum besseren Verständniss die Datei mal hochgeladen.
Könnte mir bitte nochmals jemand weiterhelfen ?
Gruß Heinz
https://www.herber.de/bbs/user/47842.xls
Option Explicit
Sub cp_wbk()
Dim MyShape As Shape, strPfaduDatei As String
Application.ScreenUpdating = False
With ThisWorkbook
strPfaduDatei = .Path & "\" & .Sheets(1).Range("B3") & _
" " & Format(.Sheets(1).Range("A6"), "mmmm YYYY")
.Sheets(1).Copy
End With
For Each MyShape In ActiveSheet.Shapes
If MyShape.AlternativeText "Neues Monat anlegen" Then MyShape.Delete
Next
ActiveWorkbook.SaveAs strPfaduDatei
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub
Sub WochenendeWeg()
If MsgBox("Wollen Sie ein neues Monat erstellen ?", vbQuestion + vbYesNo, _
" Nachfrage Neues Monat erstellen !") = vbNo Then Exit Sub
Call cp_wbk
'-------Monat um 1 Hochzählen----------
'In G1 steht jetzt eine Formel, die nicht mehr geändert werden muss,
'daher wird nur noch F1 geändert.
Range("F1") = DateAdd("m", 1, Range("F1"))
'Blattname neu bestimmen
ActiveSheet.Name = Range("G1")
Dim datStart As Date, datEnd As Date
Dim lDay As Long
Dim iRow As Integer
Dim Text As String ''
Dim a, datum
Dim quellwks As Worksheet
Dim zielwks As Worksheet
datStart = Range("F1").Value ' in der Zelle F1 befindet sich das Anfangsdatum
datEnd = Range("H1").Value ' in der Zelle H1 befindet sich das Enddatum
iRow = 6 ' Hiermit wird gesagt, dass in Zeile 6 angefangen werden soll
Set quellwks = Sheets(1)
datum = Date
a = quellwks.Cells(1, 6).Value ' + 1
Dim Titel As String ''
Titel = " * - * - * - * - * - * - * - * - * Meldung * - * - * - * - * - * - * - * " ''
If a > datum Then
Text = "Sie dürfen erst ein neues Blatt ab " & a & " einfügen." ''
MsgBox Text, vbCritical, Titel
Exit Sub
End If
'Bevor die Daten des neuen Monats eingetragen werden, alte Daten löschen.
'Anschließend Zahlenformate in den Spalten A und B wiederherstellen
'Range("A" & iRow & ":A100").EntireRow.Delete
Range("A6:A42").EntireRow.ClearContents ' Franz Zeile geändert. Statt löschen der Zeilen _
werden nur Inhalte gelöscht
Range("A6:A42").EntireRow.Interior.ColorIndex = xlColorIndexNone 'entfernt Farbe aus _
Zellbereich
Range("A6:A42").NumberFormatLocal = "TT.MM.JJJJ"
Range("B6:B42").NumberFormatLocal = "TTT"
For lDay = datStart To datEnd
Cells(iRow, 1) = lDay
Cells(iRow, 2) = lDay
iRow = iRow + 1
iRow = iRow - (Weekday(lDay, 2) = 7)
Next