|
VBA Kalenderwoche ermitteln |
|
|
|
|
Geschrieben von Horst Schulte
|
|
Samstag, 23. September 2006 |
Frage:
Ich arbeite mit Microsoft EXCEL für WINDOWS 95 / WINDOWS NT 3.51, Version 7.0. Gibt es eine Möglichkeit, die Kalenderwoche eines Datums zu berechnen?
Antwort:
Mit Hilfe der Programmiersprache VISUAL BASIC für Applikationen (VBA) von EXCEL 7.0 haben Sie die Möglichkeit aus einem Datum die Kalenderwoche berechnen zu lassen. Die Eingabe des Datums erfolgt in einem Dialog, die Ausgabe erfolgt als Meldung. Nachfolgend finden Sie ein programmiertes Beispiel sowohl in englischem als auch in deutschem VBA-Code:
Englischer Code:
Sub KW_Test()
`Aufruf der Eingabedialogbox zur Abfrage des Datums
Y = InputBox("Geben Sie ein Datum ein", "Ermitteln der Kalenderwoche", "1.1.98")
`Aufruf der Funktion zur Berechnung der Kalenderwoche
X = KW(Y)
`Ausgabe der berechneten Kalenderwoche als Meldung
MsgBox "Ihr Datum [" + Y + "] ist In : " + X
End Sub
Function KW(KwDatum)
`Deklaration der Konstanten
Const Sonntag = 1
Const Montag = 2
Const Dienstag = 3
Const Mittwoch = 4
Const Donnerstag = 5
Const Freitag = 6
Const Samstag = 7
`Fehlersprungmarke setzen
On Error GoTo Fehlermarke:
`Bestimmung der zur Berechnung notwendigen Variablen
Jahresanfang = DateSerial(Year(KwDatum), 1, 1)
VorJahresEnde = DateSerial(Year(KwDatum) - 1, 1, 1)
WochentagJahresanfang = WeekDay(Jahresanfang)
WochentagVorJahresEnde = WeekDay(VorJahresEnde)
differenz = DateValue(KwDatum) - Jahresanfang
`bestimmt die Kalenderwoche des ersten Tags des Jahres
`ab Donnerstag -> KW1 des aktuellen Jahres
`bis Mittwoch -> KW 52/53 des letzten Jahres
`mittels der Differenz wird dann die KW des Eingabedatums berechnet
Select Case WochentagJahresanfang
Case Donnerstag
`Prüfung ob es sich um eine Schaltjahr handelt
If (differenz - (WochentagJahresanfang - 6)) / 7 <= 0.5 Then
KW = "KW 53"
Else
KW = "KW " + Str(Application.RoundUp((differenz - (WochentagJahresanfang - 6)) / 7, 0))
End If
Case Montag, Dienstag, Mittwoch, Freitag, Samstag, Donnerstag
If Application.RoundUp((differenz - (WochentagJahresanfang - 6)) / 7, 0) <= 0 Then
KW = "KW 52"
Else
KW = "KW " + Str(Application.RoundUp((differenz - (WochentagJahresanfang - 6)) / 7, 0))
End If
Case Sonntag
If differenz = 0 Then differenz = 1
KW = "KW " + Str(Application.RoundUp(differenz / 7, 0))
End Select
Exit Function
Fehlermarke:
MsgBox Error()
End Function
Deutscher Code:
Sub KW_Test()
Y = EingabeDlg("Geben Sie ein Datum ein"; "Ermitteln der Kalenderwoche"; "1.1.98")
X = KW(Y)
MeldungsDlg "Ihr Datum [" + Y + "] ist in : " + X
Ende Sub
Funktion KW(KwDatum)
Konst Sonntag = 1
Konst Montag = 2
Konst Dienstag = 3
Konst Mittwoch = 4
Konst Donnerstag = 5
Konst Freitag = 6
Konst Samstag = 7
Bei Fehler GeheZu Fehlermarke:
Jahresanfang = Datumszahl(Jahr(KwDatum); 1; 1)
VorJahresEnde = Datumszahl(Jahr(KwDatum) - 1; 1; 1)
WochentagJahresanfang = Wochentag(Jahresanfang)
WochentagVorJahresEnde = Wochentag(VorJahresEnde)
differenz = Datumswert(KwDatum) - Jahresanfang
Prüfe Fall WochentagJahresanfang
Fall Donnerstag
Wenn (differenz - (WochentagJahresanfang - 6)) / 7 <= 0,5 Dann
KW = "KW 53"
Sonst
KW = "KW " + ZnF(Anwendung.Aufrunden((differenz - (WochentagJahresanfang - 6)) / 7; 0))
Ende Wenn
Fall Montag; Dienstag; Mittwoch; Freitag; Samstag; Donnerstag
Wenn Anwendung.Aufrunden((differenz - (WochentagJahresanfang - 6)) / 7; 0) <= 0 Dann
KW = "KW 52"
Sonst
KW = "KW " + ZnF(Anwendung.Aufrunden((differenz - (WochentagJahresanfang - 6)) / 7; 0))
Ende Wenn
Fall Sonntag
Wenn differenz = 0 Dann differenz = 1
KW = "KW " + ZnF(Anwendung.Aufrunden(differenz / 7; 0))
Ende Prüfe
Verlasse Funktion
Fehlermarke:
MeldungsDlg Fehler()
Ende Funktion
|
Excel