AW: Datum & KW fortlaufend auf mehrere Sheets
28.10.2016 09:15:43
baschti007
Die Datei die du hoch geladen hast einfach die Tabelle in Muster umbenennen
und dann den code Kalenderwoche starten
Gruß Basti
Function DINKw(Datum As Date) As Integer
Dim lngT As Long
lngT = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKw = ((Datum - lngT - 3 + (Weekday(lngT) + 1) Mod 7)) \ 7 + 1
End Function
Sub Kalenderwoche()
Dim ThisSheet As Workbook
Dim d As Long, i As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
StartDatum = "01.01.2016"
With ThisWorkbook
For Each ws In .Worksheets
If Not ws.Name Like "Muster" Then
ws.Delete
End If
Next
For i = 1 To 52
Sheets("Muster").Copy Before:=Sheets(ThisWorkbook.Sheets.Count)
With .Sheets(i)
Do While Not i = DINKw(DateAdd("d", d, StartDatum))
d = d + 1
Loop
.Name = "KW " & DINKw(DateAdd("d", d, StartDatum))
.Range("A5") = DINKw(DateAdd("d", d, StartDatum))
.Range("A8") = Format(DateAdd("d", d, StartDatum), "DDDD")
.Range("A11") = DateAdd("d", d, StartDatum)
.Range("A14") = Format(DateAdd("d", d + 1, StartDatum), "DDDD")
.Range("A17") = DateAdd("d", d + 1, StartDatum)
.Range("A20") = Format(DateAdd("d", d + 2, StartDatum), "DDDD")
.Range("A23") = DateAdd("d", d + 2, StartDatum)
.Range("A26") = Format(DateAdd("d", d + 3, StartDatum), "DDDD")
.Range("A29") = DateAdd("d", d + 3, StartDatum)
.Range("A32") = Format(DateAdd("d", d + 4, StartDatum), "DDDD")
.Range("A35") = DateAdd("d", d + 4, StartDatum)
d = d + 7
End With
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub