Wochen anlegen

Moin zusammen,
Ich habe diesen Code:
Option Explicit
Sub CreateWks()
Dim datStart As Date, datEnd As Date
Dim lKW As Long
Dim iKW As Integer
Dim sKW As String
Application.ScreenUpdating = False
datStart = DateSerial(Year(Date), Month(Date), 1)
datEnd = DateSerial(Year(Date), Month(Date), 31)
For lKW = datStart To datEnd Step 7
Worksheets.Add after:=Worksheets(Worksheets.Count)
iKW = ISOWeek(CDate(lKW))
If lKW = CLng(datStart) And iKW > 1 Then
sKW = iKW & ".-Woche"
ElseIf lKW >= datEnd - 7 And iKW = 1 Then
sKW = ".-Woche" & iKW
Else
sKW = Format(iKW, "00") & ".-Woche"
End If
ActiveSheet.Name = sKW
Next lKW
Application.ScreenUpdating = True
Worksheets(3).Select
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

hier im Forum gefunden und mir angepaßt.Was mir nun noch fehlt ist das es bei 5 Wochen im Monat super klappt nur bei 6 Wochen im Monat nicht(z.B.Jannuar 2006) kann mir einer da bitte weiterhelfen?
Gruß Rene

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Wochen anlegen

18.12.2005 21:00:35

Erich

AW: Wochen anlegen

18.12.2005 21:56:19

Rene

AW: Wochen anlegen

19.12.2005 10:59:35

Rene

AW: Wochen anlegen

19.12.2005 11:51:11

Erich

AW: Wochen anlegen

19.12.2005 17:56:49

Rene

Sub CreateWks() Dim datStart As Date, datEnd As Date Dim lKW As Long Dim iKW As Integer Dim sKW As String Application.ScreenUpdating = False ' datStart = DateSerial(Year(Date), Month(Date), 1) ' datEnd = DateSerial(Year(Date), Month(Date), 31) datStart = DateSerial(2006, 1, 1) datStart = datStart - Weekday(datStart, 2) + 1 ' geht auf den Montag <= datstart datEnd = DateSerial(2006, 1, 31) For lKW = datStart To datEnd Step 7 Worksheets.Add after:=Worksheets(Worksheets.Count) iKW = ISOWeek(CDate(lKW)) sKW = Format(iKW, "00") & ".-Woche" ActiveSheet.Name = sKW Next lKW Application.ScreenUpdating = True Worksheets(3).Select End Sub

Hallo Rene,
dfa kann ich dir zwei Versionen anbieten. Die erste Version könnte den Nachteil haben, dass lange Zeichenketten in Zellen (mehr als ca. 265 Zeichen) nicht vollständig kopiert werden.


Sub CreateWks3()
Dim datStart As Date, datEnd As Date
Dim lKW As Long
Application.ScreenUpdating = False
'   datStart = DateSerial(Year(Date), Month(Date), 1)
'   datEnd = DateSerial(Year(Date), Month(Date), 31)
datStart = DateSerial(2006, 1, 1)
datStart = datStart - Weekday(datStart, 2) + 1 ' geht auf den Montag <= datstart
datEnd = DateSerial(2006, 1, 31)
For lKW = datStart To datEnd Step 7
Worksheets("Vorlage").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(ISOWeek(CDate(lKW)), "00") & ".-Woche"
Next lKW
Application.ScreenUpdating = True
Worksheets(3).Select
End Sub
Sub CreateWks2()
Dim datStart As Date, datEnd As Date
Dim lKW As Long
Application.ScreenUpdating = False
'   datStart = DateSerial(Year(Date), Month(Date), 1)
'   datEnd = DateSerial(Year(Date), Month(Date), 31)
datStart = DateSerial(2006, 1, 1)
datStart = datStart - Weekday(datStart, 2) + 1 ' geht auf den Montag <= datstart
datEnd = DateSerial(2006, 1, 31)
For lKW = datStart 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
Application.ScreenUpdating = True
Worksheets(3).Select
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread