Ich hatte mein Problem schon mal unter "Stundennachweiß" erläutert,aber leider keine Antwort bekommen.Versuche deshalb noch ein mal Hilfe zu bekommen.
Was ich nun schon herausgefunden habe ist das der Fehler nur ist wenn der Monatsende der 30. ist und dieser auf einen Sonntag fällt,dann legt es mir die Woche des folge Monats an.Sonst klappt es prima.
Das Problem liegt bestimmt im folgendem Code ich kann ihn aber leider nicht selber finden.
Sub WochenAnlegen()
Dim datStart As Date, datEnd As Date, lKW As Long
Dim strName As String
On Error Resume Next
Application.ScreenUpdating = False
datStart = DateSerial(Year(Date), Month(Date), 1)
datEnd = DateSerial(Year(Date), Month(Date), 31)
datStart = datStart - Weekday(datStart, 2) + 1 ' geht auf den Montag datEnd = DateSerial(Year(Date), Month(Date), 31)
For lKW = datStart + 7 To datEnd Step 7
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(ISOWeek(CDate(lKW)), "00") & ".-Woche"
Sheets("Vorlage").Cells.Copy ActiveSheet.Cells(1, 1)
Range("AK1").Value = CDate(lKW)
Next lKW
With Worksheets(1)
.Name = Format(ISOWeek(CDate(datStart)), "00") & ".-Woche"
strName = Left(.Name, 3)
.Select
End With
If Year(datStart) Year(Date) Or Month(datStart) Month(Date) Then
Range("AK1").Value = DateSerial(Year(Date), Month(Date), 1)
Else
Range("AK1").Value = CDate(datStart)
End If
strName = JahrOrdnerAnlegen(datEnd) & strName _
& "-" & Format(ISOWeek(CDate(lKW - 7)), "00") & ".Woche.xls"
ActiveWorkbook.SaveAs strName
Application.ScreenUpdating = True
End Sub
Private Function ISOWeek(dat As Date) As Integer
With WorksheetFunction
ISOWeek = Fix((dat - .Weekday(dat, 2) - _
DateSerial(Year(dat + 4 - _
.Weekday(dat, 2)), 1, -10)) / 7)
End With
End Function
Function JahrOrdnerAnlegen(datBis As Date) As String
Dim sPath As String, dat As Date
dat = Range("AK1").Value
sPath = "C:\Temp\Stunden\"
On Error Resume Next
MkDir sPath & Year(dat)
sPath = sPath & Year(dat) & "\"
MkDir sPath & Format(dat, "mmmm")
sPath = sPath & Format(dat, "mmmm") & "\"
On Error GoTo 0
JahrOrdnerAnlegen = sPath
End Function
Weithin ist das Problem von 1. unter "Stundennachweiß" auch noch offen.
Es wäre nun prima wenn sich einer mein Problem mal ansieht und mir dann wenigstes sagt ob es eine Lösung dafür gibt oder ob man es anders lösen muß.
Hier ist die Tabelle noch mal:
https://www.herber.de/bbs/user/30558.xls
Danke im voraus
Gruß Rene