Moin
Sub Zeitplan_Blank_füllen()
Dim wkb As Workbook
Dim wks_Uebersicht As Worksheet
Dim Gelb As Long
Dim Blau As Long
Dim Rot As Long
Dim kw As Long 'Kalenderwoche zu Beginn des Monats
Dim Start As Date
Dim Farbe As Long
Dim Zeilenzahl As Long
Dim Tage As Long
Dim Monat As Long
Dim ls As Long
Set wkb = ThisWorkbook
Set wks_Uebersicht = wkb.Worksheets("Uebersicht")
Application.DisplayAlerts = False
Blau = RGB(180, 198, 231)
Rot = RGB(252, 228, 214)
Gelb = RGB(255, 255, 153)
Start = InputBox("Bitte den Monatsersten eingeben!", "Datum", Format(Date, "dd.mm.yyyy"))
If IsDate(Start) Then
Tage = Day(DateSerial(Year(Start), Month(Start) + 1, 0))
End If
WT = Format(Start, "dddd")
Intervall = 0
e = 1 'Startspalte
Farbe = Gelb
With wks_Uebersicht
For i = 1 To Tage
.Range(.Cells(1, e), .Cells(1, e)) = Format(Start, "dddd")
.Range(.Cells(1, e), .Cells(1, e + 1)).MergeCells = True
'.Range(.Cells(1, e), .Cells(1, e + 1)).HorizontalAlignment = xlCenter
.Range(.Cells(2, e), .Cells(2, e)) = Start
.Range(.Cells(2, e), .Cells(2, e + 1)).MergeCells = True
'.Range(.Cells(2, e), .Cells(2, e + 1)).HorizontalAlignment = xlCenter
.Range(.Cells(3, e), .Cells(3, e)) = "Von"
.Range(.Cells(3, e + 1), .Cells(3, e + 1)) = "Bis"
.Range(.Cells(1, e), .Cells(3, e + 1)).Interior.Color = Farbe
If Format(Start, "dddd") = "Sonntag" Then
.Range(.Cells(1, e + 2), .Cells(1, e + 2)) = "KW " & KALENDERWOCHE_DIN( _
Start)
.Range(.Cells(2, e + 2), .Cells(3, e + 2)).MergeCells = True
.Range(.Cells(2, e + 2), .Cells(3, e + 2)) = "Stunden"
'.Range(.Cells(2, e + 2), .Cells(3, e + 2)).HorizontalAlignment = xlCenter
'.Range(.Cells(2, e + 2), .Cells(3, e + 2)).VerticalAlignment = xlCenter
.Range(.Cells(2, e + 2), .Cells(3, e + 2)).Interior.Color = Blau
e = e + 3
Start = Start + 1
Else
e = e + 2
Start = Start + 1
End If
If Farbe = Gelb Then
Farbe = Rot
ElseIf Farbe = Rot Then
Farbe = Gelb
End If
Next i
ls = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(3, ls)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 1), .Cells(3, ls)).VerticalAlignment = xlCenter
With .Range(.Cells(1, 1), .Cells(3, ls))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
End With
Application.DisplayAlerts = True
End Sub
Function KALENDERWOCHE_DIN(Datum As Date) As Integer
' von Christoph Kremer, Aachen
' Berechnt die KW nach DIN 1355
Dim t&
t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
KALENDERWOCHE_DIN = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
Gruß Gerd