Tabellenblatt kopieren mit weiterer Datumsfunktion
18.10.2015 15:28:16
Stefan
Ich habe bereits einen Beitrag geschrieben, aber auf diesen kann ich leider nicht mehr antworten siehe Link darunter und ich hoffe es kann mir die Funktion jemand noch weiter anpassen.
https://www.herber.de/forum/archiv/1448to1452/t1451803.htm
Das Problem ist das es von Sepp schon perfekt für das Jahr 2015 funktioniert aber nicht für das Jahr 2016.
Ich möchte das mir das Tabellenblatt mit meiner Vorlage das KW heißt (KW = Kalenderwoche) steht die KW aufs Jahr hochrechnet, und automatisch das Datum einfügt.
Das heißt es muss KW1 - KW52 geben und in den Zellen B3:F3 soll immer das jeweilige Datum von Mo - Fr stehen.
2015 funktioniert es mit dem darunter liegenden Skript super, nur 2016 ist eine Kalenderwoche zuviel und der Beginn ist falsch.
Das heißt für das Jahr 2016 würde KW1 mit dem Datum 04.01.16 - 08.01.16 beginnen, bei dem Script startet es aber schon mit 28.12.15 - 01.01.16 und es gibt KW53 statt KW52.
Ich hoffe es kann mir das jemand noch ein wenig anpassen. Den meine Kenntnisse reichen dafür leider nicht aus.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub BlaetterAnlegen()
Dim varYear As Variant, lngWeek As Long, lngDay As Long
Dim datWeek As Date
varYear = Application.InputBox("Bitte gewünschtes Jahr eingeben:", "Blätter anlegen", CStr(Year(Date)), Type:=2)
If Not varYear = False Then
For lngWeek = 1 To 53
datWeek = DateFromKW(varYear, lngWeek)
If Year(datWeek) = Clng(varYear) Or Year(datWeek + 4) = Clng(varYear) Then
Sheets(1).Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = "KW" & lngWeek
.Range("G1") = .Name
For lngDay = 0 To 4
'B3:F3
.Cells(3, 2 + lngDay) = datWeek + lngDay
Next
End With
End If
Next
End If
End Sub
Private Function DateFromKW(ByVal Year As Integer, ByVal KW As Integer) As Date
DateFromKW = DateSerial(Year, 1, 7 * KW - 3 - Weekday(DateSerial(Year, 1, 1), 7))
End Function