Option Explicit
'*************************************************
'*** Regel der Berechnung der Kalenderwoche nach deutscher Regelung:
'*** KW1 im Jahr ist die Woche, die den ersten Donnerstag des Jahres enthält,
'*** mit anderen Worten - die erste Woche hat mindestens 4 Tage.
'*** KW53 ist vorhanden, wenn 4 Tage im gleichen Kalenderjahr liegen
Private Type KWAnfEnde_struct
dDateAnf As Date
dDateEnde As Date
bVorhanden As Boolean
End Type
Sub KWStringAnfEndeInD23()
Const cRANGE_DATUM = D23
Const cBLTNAME_ANFANG = KW
Dim wb As Workbook, ws As Worksheet
Dim KWs(1 To 53) As KWAnfEnde_struct
Dim lJahr As Long, sStr As String, x As Long
If Not EingabeJahr(lJahr) Then GoTo AUFRAEUMEN
Call KWs_DatumAnfangEndeBerechnen(lJahr, KWs)
->Datumstring in D23 der KW-Blätter der aktuellen Mappe eintragen
->Form: 01.01. - 07.01.06
Set wb = ActiveWorkbook
For x = LBound(KWs()) To UBound(KWs())
Set ws = Nothing
On Error Resume Next
If KWs(x).bVorhanden Then
->Datumsstring in KW-Blatt eintragen
Set ws = wb.Worksheets(cBLTNAME_ANFANG & x)
Err.Clear: On Error GoTo 0
If ws Is Nothing Then
MsgBox Datum konnte auf Blatt-> & cBLTNAME_ANFANG & x &-> nicht eingetragen werden.
GoTo AUFRAEUMEN
End If
sStr = _
Format(Day(KWs(x).dDateAnf), 00) & . & _
Format(Month(KWs(x).dDateAnf), 00) & . & _
- & _
Format(Day(KWs(x).dDateEnde), 00) & . & _
Format(Month(KWs(x).dDateEnde), 00) & . & _
Right(Format(Year(KWs(x).dDateEnde), 00), 2)
With ws.Range(cRANGE_DATUM): .NumberFormat = @: .Value = sStr: End With
Else
Set ws = wb.Worksheets(cBLTNAME_ANFANG & x)
Err.Clear: On Error GoTo 0
If Not ws Is Nothing Then
MsgBox cBLTNAME_ANFANG & x & ist im Jahr & lJahr & nicht exisitent.
End If
End If
Next
AUFRAEUMEN:
Set ws = Nothing: Set wb = Nothing
End Sub
'**************************************************************************************
Private Function KWs_DatumAnfangEndeBerechnen(lJahr As Long, KWs() As KWAnfEnde_struct)
->Liefert Anfangs und Enddatum der KW1-53 des Jahres
->KW53 ist vorhanden, wenn 4 Tage im gleichen Kalenderjahr liegen
Dim lTag As Long, lMonat As Long, x As Long
Dim dDate As Date, dDateJahresanfang As Date, dDateJahresende As Date
->Anfangsdatum der KW1 feststellen
dDateJahresanfang = 1.1. & lJahr
dDate = 1.1. & lJahr
Do
If WeekDay(dDate) = vbSunday And _
DateDiff(d, dDateJahresanfang, dDate) >= 3 Then Exit Do
dDate = DateAdd(d, 1, dDate)
Loop
KWs(1).dDateAnf = DateAdd(d, -6, dDate)
If Month(KWs(1).dDateAnf) <> 1 Then KWs(1).dDateAnf = dDateJahresanfang
->EndeDatum der KW1
KWs(1).dDateEnde = dDate
KWs(1).bVorhanden = True
->Anfangs und Enddatum für KW2-53 berechnen
For x = 2 To 53
KWs(x).dDateAnf = DateAdd(d, 1, KWs(x - 1).dDateEnde)
KWs(x).dDateEnde = DateAdd(d, 6, KWs(x).dDateAnf)
KWs(x).bVorhanden = True
Next
->KW53 prüfen, ob mindestens 4 Tage im Jahr liegen
dDateJahresende = 31.12. & lJahr
If DateDiff(d, KWs(53).dDateAnf, dDateJahresende) < 3 Then KWs(53).bVorhanden = False
End Function
'**************************************************************************************
Private Function EingabeJahr(lJahr As Long) As Boolean
Dim s As String
s = Year(Now())->vorbesetzen mit aktuellem Jahr
Do
s = InputBox( _
Bitte geben sie das Jahr vierstellig ein., _
Eingabe Jahr für KW-String in KW-Blätter(D23) eintragen., _
s)
If s = Then Exit Function
On Error Resume Next
lJahr = s
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0: MsgBox Eingabe unzulässig.
Else
On Error GoTo 0
If lJahr < 2000 And lJahr > 2038 Then
MsgBox _
Eingabe unzulässig. & vbLf & _
Bitte Jahreszahl zwischen 2000 und 2038 angeben.
Else
->Eingabe ok
EingabeJahr = True
Exit Do
End If
End If
Loop
End Function
