Kalenderwochen per VBA
26.02.2019 11:05:39
Titus
ich bin gerade dabei in Excel einen Einsatzplan zu programmieren.
Dabei generiert sich der Kalender immer vom 25.12. des Vorjahres bis zum 03.02.des nächsten Jahres. Beispiel: 25.12.2018-03.02.2020
Ich habe nun eine Zeile C2 in welche ich das Jahr eingebe und aus welcher automatisch die unterschiedlichen Daten eingetragen werden (in Zeile 5). Darunter stehen die Wochentage.
In Zeile 2 sollen nun die Kalenderwochen dargestellt werden. Per Makro habe ich es schon geschafft, das automatisch die Zellen wochenweise verbunden und eingerahmt werden. Jetzt muss nur noch im Bezug auf das Anfangsdatum der Woche die jeweilige Kalenderwoche errechnet und eingetragen werden. Wie mache ich das?
Was ich aktuell in VBA habe:
Sub Kalenderwoche()
Dim i As Integer
Dim a As Integer
i = 7
a = 0
Range(Range("C2"), Range("OV2")).Borders.LineStyle = x1None
Range(Range("G2"), Range("OV2")).MergeCells = False
Do Until Cells(6, i) = "Mo"
If Cells(6, i) = "So" Then
Range(Cells(2, i - a), Cells(2, i)).MergeCells = True
Range(Cells(2, i - a), Cells(2, i)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Else: a = a + 1
End If
i = i + 1
Loop
Do Until Cells(6, i) = ""
If Cells(6, i) = "So" Then
Range(Cells(2, i - 6), Cells(2, i)).MergeCells = True
Range(Cells(2, i - 6), Cells(2, i)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End If
i = i + 1
Loop
Range("G7").Select
End Sub