Excel VBA - Monat ohne Sonntage

Aufgabe war einen Monat mit Datum und Wochentag aufzulisten. Es durfte allerdings kein Sonntag in der Liste erscheinen. Dieses Makro bewältigt das Problem. Wenn das Makro gestartet wird erscheint erst einmal eine Inputbox, welche nach dem Startdatum fragt. Hier gebt Ihr dann zum Beispiel den 01.01.2007 ein. Erst wird für den Monat 1 ein Kalender generiert - danach werden alle Sonntage gelöscht.

 

Tabelle1

  A B
2 Montag 01.01.2007
3 Dienstag 02.01.2007
4 Mittwoch 03.01.2007
5 Donnerstag 04.01.2007
6 Freitag 05.01.2007
7 Samstag 06.01.2007
8 Montag 08.01.2007
9 Dienstag 09.01.2007
10 Mittwoch 10.01.2007
11 Donnerstag 11.01.2007
12 Freitag 12.01.2007
13 Samstag 13.01.2007
14 Montag 15.01.2007
15 Dienstag 16.01.2007
16 Mittwoch 17.01.2007
17 Donnerstag 18.01.2007
18 Freitag 19.01.2007
19 Samstag 20.01.2007
20 Montag 22.01.2007
21 Dienstag 23.01.2007
22 Mittwoch 24.01.2007
23 Donnerstag 25.01.2007
24 Freitag 26.01.2007
25 Samstag 27.01.2007
26 Montag 29.01.2007
27 Dienstag 30.01.2007
28 Mittwoch 31.01.2007


Option Explicit

Sub Wochentage_eintragen()
    Dim i As Integer
    Dim j As Date
    Application.ScreenUpdating = False
    j = InputBox("Anfangsdatum eingeben:")
    Range("A2:B31").ClearContents
    Range("B2") = j
    Range("B2") = Format(Range("B2"), "DD.MM.YYYY")
    Range("A2") = Weekday(Range("B2"))
    Range("A2") = Format(Range("A2"), "DDDD")
    For i = 1 To 31
        Cells(2 + i, 2) = CDate(Cells(i + 1, 2)) + 1
        Cells(2 + i, 2) = Format(Cells(2 + i, 2), "DD.MM.YYYY")
        Cells(2 + i, 1) = Weekday(Cells(2 + i, 2))
        Cells(2 + i, 1) = Format(Cells(2 + i, 1), "DDDD")
    Next
    For i = 33 To 2 Step -1
    If Month(Cells(i, 2)) <> Month(Range("B2")) Then Rows(i).Delete Shift:=xlUp
    If Cells(i, 1) = "Sonntag" Then Rows(i).Delete Shift:=xlUp
    Next
    Application.ScreenUpdating = True
End Sub

Cookies erleichtern die Bereitstellung unserer Dienste. Mit der Nutzung unserer Dienste erklären Sie sich damit einverstanden, dass wir Cookies verwenden.
Weitere Informationen Ok