AW: Kalenderwoche VBA
14.07.2020 19:47:06
Frank
Hallo,
danke für die Antwort.
Leider funktioniert die auch nicht bei 2021
hier ist mal der Original Code (muss Tabellenblatt 1-12 vorhanden sein - für alle Monate)
Option Explicit
Sub Kalender_Farben_Datum_2()
Dim Monat, Tag As Long
Dim dDatum As Date
Dim Spalte As Long
Dim Jahr, Farbe, Schicht, f As String
Dim wks As Long
Application.ScreenUpdating = False
Jahr = InputBox("Bitte Jahr eingeben", "Jahr", Year(Now) + 1)
Schicht = InputBox("Welche Schicht wird gestartet?", "Farbe", "1, 2 oder 3")
If Not IsNumeric(Schicht) Or Not IsNumeric(Jahr) Or Len(Jahr) 4 Or Len(Schicht) 1 _
Then
MsgBox "Falsche Eingabe. Bitte erneut versuchen.", vbOKOnly, "Falsche Eingabe"""
Exit Sub
End If
Monat = 1
Select Case Schicht
Case 1: Farbe = 65535
Case 2: Farbe = 49407
Case 3: Farbe = 5296274
End Select
For wks = 1 To 12
Sheets(wks).Activate
'Datum
With Range("H2:AL3")
.Interior.Pattern = xlNone
.ClearContents
End With
dDatum = DateSerial(Jahr, Monat, 1)
Spalte = 8
With ActiveSheet
.Range("C2").Value = Jahr
Do
For Tag = 1 To 31
With .Cells(2, Spalte)
'### Färben ###
If Weekday(dDatum) = 1 Or Weekday(dDatum) = 7 Then
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 90
.Font.Size = 11
With .Interior
.Pattern = xlGray50
.PatternColorIndex = 2
.Color = 255
End With
'Wochenende mit einfärben -
'Zeile anpassen
With Range(Cells(4, Spalte), Cells(48, Spalte)).Interior
.Pattern = xlGray50
.PatternColorIndex = 2
.Color = 255
End With
Else
'wenn nicht Wochenende, dann weiß
With Range(Cells(4, Spalte), Cells(48, Spalte)).Interior
.Pattern = xlAutomatic
.PatternColorIndex = 2
.Color = 16777215 'weiß
End With
f = Format(dDatum, "w", vbMonday)
With .Interior
.Color = Farbe
.Pattern = xlAutomatic
End With
If f = 5 Then
If Farbe = 65535 Then
Farbe = 5296274 'Nachtschicht
ElseIf Farbe = 5296274 Then
Farbe = 49407 'Spätschicht
ElseIf Farbe = 49407 Then
Farbe = 65535 'Frühschicht
End If
f = 0
End If
.Font.Bold = False
End If
'### Datum eintragen ###
If Weekday(dDatum) = 2 Or Day(dDatum) = 1 Then 'wenn Montag
Cells(2, Spalte).NumberFormat = "General"
Cells(2, Spalte).Value = Format(dDatum, "DDDD", vbMonday) & " - _
" & Format(dDatum, "ww", vbMonday)
Else
.NumberFormat = "dddd"
.Value = dDatum
End If
With Cells(3, Spalte)
.NumberFormat = "d."
.Value = dDatum
End With
End With
dDatum = dDatum + 1
Spalte = Spalte + 1
If Month(dDatum) Monat Then Exit For
Next Tag
Loop While Month(dDatum) = Monat
Range("A1").Select
Monat = Monat + 1
End With
Next wks
Sheets(1).Activate
Application.ScreenUpdating = True
End Sub
ich bin für alle Änderungen und Verbesserungen offen
danke
Frank