Ich habe diesen Code von Volker bekommem:
Option Explicit
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)
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)
Next lKW
With Worksheets(1)
.Name = Format(ISOWeek(CDate(datStart)), "00") & ".-Woche"
strName = Left(.Name, 3)
.Select
End With
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
sPath = "D:\Arbeitsachen\Stunden\"
On Error Resume Next
MkDir sPath & Year(datBis)
sPath = sPath & Year(datBis) & "\"
MkDir sPath & Format(datBis, "mmmm")
sPath = sPath & Format(datBis, "mmmm") & "\"
On Error GoTo 0
JahrOrdnerAnlegen = sPath
End Function
Kann Volker oder natürlich auch jeder andere bitte hierbei helfen?
Dieser klappt auch prima bis auf das aktuelle Datum. Bei diesem Code wir immer das aktuelle Wochendatum eingetragen.Dieses sollte ja auch so sein aber was nun das Problem ist es wird in jedes Blatt das Wochendatum eingetragen und dieses ist doch nicht so gut.
Gibt es nun eine Möglichkeit das in dem Code so zuändern das ich immer in dem nächsten Tabellenblatt das Datum der Woche habe?
Falls die Erklärung doch nicht so verständlich war schicke ich die Tabelle mal hoch.
Für Hilfe wäre ich sehr dankbar.
Gruß Rene