Sub Kalender1() Dim IntWT As Integer Range("A5:B" & ActiveSheet.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row).Clear Cells(5, 1).Value = DateSerial(Year(Cells(1, 2)), Month(Cells(1, 2)), Day(Cells(1, 2))) Cells(5, 1).AutoFill Range("A5:A41") Range("A5:A41").NumberFormat = "dd.mm.yyyy" IntWT = 5 If WeekdayName(Weekday(Cells(1, 2) - 1)) <> "Montag" Then Rows(IntWT & ":" & IntWT).Insert Shift:=xlDown Range("A" & IntWT).NumberFormat = "KW " & "##" Cells(IntWT, 1) = EKalenderWoche(Cells(IntWT + 1, 1)) IntWT = IntWT + 1 End If Do If Month(Cells(1, 2)) = Month(Cells(IntWT, 1)) Then Cells(IntWT, 2) = WeekdayName(Weekday(Cells(IntWT, 1) - 1)) If Cells(IntWT, 2) = "Montag" Then Rows(IntWT & ":" & IntWT).Insert Shift:=xlDown Range("A" & IntWT).NumberFormat = "KW " & "##" Cells(IntWT, 1) = EKalenderWoche(Cells(IntWT + 1, 1)) IntWT = IntWT + 1 End If Else Cells(IntWT, 1) = "" Cells(IntWT, 2) = "" End If IntWT = IntWT + 1 Loop While IntWT < ActiveSheet.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row + 1 End Sub
Function EKalenderWoche(Edatum As Date) As Integer EKalenderWoche = (Edatum - DateSerial(Year(Edatum + (8 - Weekday(d)) Mod 7 - 3), 1, 1) - 3 + (Weekday(DateSerial(Year(Edatum + (8 - Weekday(d)) Mod 7 - 3), 1, 1)) + 1) Mod 7) \ 7 + 1 End Function
Sub Kalender1() Dim IntWT As Integer Range("A5:B" & ActiveSheet.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row).Clear Cells(5, 1).Value = DateSerial(Year(Cells(1, 2)), Month(Cells(1, 2)), Day(Cells(1, 2))) Cells(5, 1).AutoFill Range("A5:A41") Range("A5:A41").NumberFormat = "dd.mm.yyyy" IntWT = 5 If WeekdayName(Weekday(Cells(1, 2) - 1)) <> "Montag" Then Rows(IntWT & ":" & IntWT).Insert Shift:=xlDown Range("A" & IntWT).NumberFormat = "KW " & "##" Cells(IntWT, 1) = EKalenderWoche(Cells(IntWT + 1, 1)) IntWT = IntWT + 1 End If Do If Month(Cells(1, 2)) = Month(Cells(IntWT, 1)) Then Cells(IntWT, 2) = WeekdayName(Weekday(Cells(IntWT, 1) - 1), True) If Cells(IntWT, 2) = "Mo" Then Rows(IntWT & ":" & IntWT).Insert Shift:=xlDown Range("A" & IntWT).NumberFormat = "KW " & "##" Cells(IntWT, 1) = EKalenderWoche(Cells(IntWT + 1, 1)) IntWT = IntWT + 1 End If Else Cells(IntWT, 1) = "" Cells(IntWT, 2) = "" End If IntWT = IntWT + 1 Loop While IntWT < ActiveSheet.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row + 1 End Sub
Sub Kalender1() Dim IntWT As Integer With ActiveSheet .Range("A5:B" & .Range(.Cells(Rows.Count, 1), .Cells(Rows.Count, 1)).End(xlUp).Row).Clear .Cells(5, 1).Value = DateSerial(Year(.Cells(1, 2)), Month(.Cells(1, 2)), Day(.Cells(1, 2))) .Cells(5, 1).AutoFill .Range("A5:A41") .Range("A5:A41").NumberFormat = "dd.mm.yyyy" IntWT = 5 If WeekdayName(Weekday(.Cells(1, 2) - 1)) <> "Montag" Then .Rows(IntWT & ":" & IntWT).Insert Shift:=xlDown .Range("A" & IntWT).NumberFormat = "KW " & "##" .Cells(IntWT, 1) = EKalenderWoche(ActiveSheet.Cells(IntWT + 1, 1)) IntWT = IntWT + 1 End If Do If Month(.Cells(1, 2)) = Month(Cells(IntWT, 1)) Then .Cells(IntWT, 2) = WeekdayName(Weekday(.Cells(IntWT, 1) - 1)) If .Cells(IntWT, 2) = "Montag" Then .Rows(IntWT & ":" & IntWT).Insert Shift:=xlDown .Range("A" & IntWT).NumberFormat = "KW " & "##" .Cells(IntWT, 1) = EKalenderWoche(.Cells(IntWT + 1, 1)) IntWT = IntWT + 1 End If Else .Cells(IntWT, 1) = "" .Cells(IntWT, 2) = "" End If IntWT = IntWT + 1 Loop While IntWT < .Range(ActiveSheet.Cells(Rows.Count, 1), ActiveSheet.Cells(Rows.Count, 1)).End(xlUp).Row + 1 End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$1" Then Call Kalender1 Application.EnableEvents = True End Sub
58.4k Fragen
249k Antworten
7k Nutzer