AW: Zeitraster erstellen mit vba / Kalendergestaltung
08.09.2018 00:47:25
Markus
Hallo Daniel,
ich muss dir recht geben - ist nciht gut beschrieben. Ich versuche gerade meine VBA Kenntnisse darüber zu erweitern indem ich bestehende BEispiele versuche zu ergänzen. Zum besseren Verständnis lade ich die Datei hoch in der Hoffnung, Hilfe zu bekommen, wie ich das starre 1h Raster im Code durch eine variables ersetzen kann (Startzeit, Raster, Stopzeit). Der Rest des Codes tut eigentlich was ich mir erhoffe.
Meine Problemzone liegt bei der Anpassung "'Zeitspalte einfügen"
Sub Wochenkalender()
Dim intYear As Integer ' Jahr
Dim bytWS As Byte ' Blätter für 52 Woche
Dim bytTitle As Byte ' Wochentage pro Blatt
Dim intDay1 As Integer ' 1. Tag im Jahr
Dim bytCol As Byte ' Spaltenindex
Dim bytWeekDay As Byte ' Wochentage pro Blatt
Application.ScreenUpdating = False
' Das Jahr aus Zelle A29 beziehen
intYear = Range("A29")
' Fehlende Tabellenblätter für 53 Wochen einfügen
For bytWS = Worksheets.Count + 1 To 53
Worksheets.Add After:=Worksheets(Worksheets.Count)
Next bytWS
' Den ersten Tag im Jahr positionieren
For intDay1 = 2 To 8
With Worksheets(1)
' Montag bis Freitag auf 1. Tabellenblatt einfügen
For bytTitle = 1 To 7
.Cells(1, bytTitle + 1) = WeekdayName(bytTitle)
Next bytTitle
' Wochentagsübereinstimmung suchen
If Format(DateSerial(intYear, 1, 1), "dddd") = _
.Cells(1, intDay1) Then
' 1. Datum eintragen
.Cells(2, intDay1) = DateSerial(intYear, 1, 1)
' 1. Woche mit allfälligen Tagen vom alten Jahr befüllen
If intDay1 > 2 Then
.Cells(2, intDay1).AutoFill _
Destination:=.Range(.Cells(2, 2), _
.Cells(2, intDay1))
End If
' 1. Tag im Jahr rot einfärben
.Cells(2, intDay1).Font.Color = vbRed
' Zähler für weitere Spalten aufbereiten
bytCol = intDay1 + 1
End If
End With
Next intDay1
' Startvariable für die weiteren Tage
intDay1 = 2
For bytWS = 1 To 53
With Worksheets(bytWS)
' Tabellenblätter benennen (Kalenderwoche)
.Name = "KW " & bytWS
' Montag bis Freitag pro Tabellenblatt einfügen
For bytTitle = 1 To 7
.Cells(1, bytTitle + 1) = WeekdayName(bytTitle)
Next bytTitle
' Zeitspalte einfügen
.Range("A3") = "00:00"
.Range("A3").AutoFill Destination:=.Range("A3:A26")
' Formatierungen Tage und Zeit
With .Range("B1:H2,A1:A26")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Interior.ColorIndex = 15
End With
' Formatierungen Zeitrahmen (zweifarbig)
.Range("B3:H10,B20:H26").Interior.ColorIndex = 37
.Range("B11:H19").Interior.ColorIndex = 34
' Rahmenlinien einfügen
With .Range("A3:H26")
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
' Pro Tabellenblatt eine Woche aufbereiten
For bytWeekDay = bytCol To 8
' Datumsangaben an Zellen übergeben
Worksheets(bytWS).Cells(2, bytCol) = _
DateSerial(intYear, 1, intDay1)
' Spaltenzahl pro Tag um 1 erhöhen
bytCol = bytCol + 1
' Tage aufzählen
intDay1 = intDay1 + 1
Next bytWeekDay
' Spaltenindex für die nächste Woche aufbereiten
bytCol = 2
End With
Next bytWS
' Zur ersten Zelle des ersten Tabellenblattes springen
Application.Goto Worksheets(1).Range("A1")
Application.ScreenUpdating = True
End Sub
Vielen Dank nochmal für die Nachhilfe
Grüße
Markus
PS: Der Versuch scheitert die Datei hochzuladen - obwohl ich die gleichen Zugangsdaten verwende werden diese als nciht korrket zurückgewiesen.