Option Explicit
Sub TagesBlattBltNameAusDatumF9()
->Kennzeichen für Tagesblatt: enthält .20
->(Es muß also in der Ausgangsposition jedes Tagesblatt mindestens
-> diesen String im Blatnamen enthalten)
Const cBLT_TAGESBLATT_KNG As String = .20
->Aus F9 des jeweiligen Blattes wird der Soll-Blattname definiert:
->dd.mm.yyyy
Const cRANGE_DATUM = F9
->wenn daraus kein vernünftiges Datum erstellbar ist,
->wird eine Meldung ausgegeben.
->Der Blattname wird mit dem soll-Blattnamen verglichen.
->Ist er unterschiedlich wird der Blattname auf Soll-Blattname geändert.
Dim ws As Worksheet
Dim sBltNameIst As String, sBltNameSoll As String
Dim pos As Long, x As Long
->
For x = 1 To ThisWorkbook.Worksheets.Count
Set ws = ThisWorkbook.Worksheets(x)
sBltNameIst = ws.Name
pos = InStr(1, sBltNameIst, cBLT_TAGESBLATT_KNG)
->Tagesblatt ? -> dann umbenennen, damit doppelte Namensvergabe vermieden wird
If pos > 0 Then ws.Name = xxxx & ws.Name
Next
For x = 1 To ThisWorkbook.Worksheets.Count
Set ws = ThisWorkbook.Worksheets(x)
sBltNameIst = ws.Name
pos = InStr(1, sBltNameIst, cBLT_TAGESBLATT_KNG)
->Tagesblatt ?
If pos > 0 Then
->SollNamen erstellen
On Error Resume Next
sBltNameSoll = Format(ws.Range(cRANGE_DATUM).Value, dd.mm.yyyy)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox _
Auf Blatt & sBltNameIst & ist in & cRANGE_DATUM & _
kein vernünftiges Datum enthalten. & vbLf & _
(Umwandlung)
Else
On Error GoTo 0
If Not IsDate(sBltNameSoll) Then
MsgBox _
Auf Blatt & sBltNameIst & ist in & cRANGE_DATUM & _
kein vernünftiges Datum enthalten. & vbLf & _
(Not Isdate())
Else
->Sollnamen setzen, wenn ungleich Istname
If sBltNameIst <> sBltNameSoll Then
ws.Name = sBltNameSoll
End If
End If
End If
End If
Next
AUFRAEUMEN:
Set ws = Nothing
End Sub
'**************************************************************************
Sub TagesBlattBltLascheFarbeSetzen()
'*** sucht nach Tagesblättern mit Blattnamen dd.mm.yyyy zum
'*** Ausgangsdatum ist das Datum in A7 auf dem Blatt Inventar
'***
'*** Blattlaschen-Farben werden gestezt:
'*** - Wochenenden mit Wochenend-Farbe
'*** - Farben 1. Woche bis 5. Woche
'*** - nicht relevant für diesen Monat
'*** Ausgangsdatum ist das Datum in A7 auf dem Blatt Inventar
'***
'!!! ab Excel 2003 !!!
->Farbindexe
Const cFARBE_WOCHE1 = 3 ->rot
Const cFARBE_WOCHE2 = 4 ->grün
Const cFARBE_WOCHE3 = 5 ->blau
Const cFARBE_WOCHE4 = 39 'lila
Const cFARBE_WOCHE5 = 35 'türkis
Const cFARBE_NICHTRELEVANT = 15 ->hellgrau
Const cFARBE_WOCHENENDE = 6 ->gelb
Const cBLTNAME_INVENTAR = Inventar
Const cBLTNAME_INVENTAR_RANGEDATUM = A7
Dim wb As Workbook, ws As Worksheet
Dim lWoche As Long, lMonat As Long, lJahr As Long, x As Long
Dim dDateAusgang As Date, dDateTagesBlatt As Date
Dim sBlattname As String
->Datum as Blatt Inventar
Set wb = ThisWorkbook
On Error Resume Next
Set ws = wb.Worksheets(cBLTNAME_INVENTAR)
Err.Clear: On Error GoTo 0
If ws Is Nothing Then
MsgBox Blatt & cBLTNAME_INVENTAR & nicht vorhanden.
GoTo AUFRAEUMEN
End If
If Not IsDate(ws.Range(cBLTNAME_INVENTAR_RANGEDATUM).Value) Then
MsgBox Auf Blatt & cBLTNAME_INVENTAR & in Zelle & cBLTNAME_INVENTAR_RANGEDATUM & ist kein vernünftiges Datum
GoTo AUFRAEUMEN
End If
dDateAusgang = ws.Range(cBLTNAME_INVENTAR_RANGEDATUM).Value
lMonat = Month(dDateAusgang)
lJahr = Year(dDateAusgang)
lWoche = 1
dDateTagesBlatt = 01. & lMonat & . & lJahr
For x = 1 To 31
sBlattname = Format(dDateTagesBlatt, dd.mm.yyyy)
On Error Resume Next
Set ws = Nothing
Set ws = wb.Worksheets(sBlattname)
Err.Clear: On Error GoTo 0
If ws Is Nothing Then
MsgBox Blatt & sBlattname & nicht vorhanden.
Else
If Month(dDateAusgang) = Month(dDateTagesBlatt) Then
If Weekday(dDateTagesBlatt) <> vbSunday And _
Weekday(dDateTagesBlatt) <> vbSaturday Then
Select Case lWoche
Case 1: ws.Tab.ColorIndex = cFARBE_WOCHE1
Case 2: ws.Tab.ColorIndex = cFARBE_WOCHE2
Case 3: ws.Tab.ColorIndex = cFARBE_WOCHE3
Case 4: ws.Tab.ColorIndex = cFARBE_WOCHE4
Case 5: ws.Tab.ColorIndex = cFARBE_WOCHE5
End Select
If Weekday(dDateTagesBlatt) = vbFriday Then
->Wochenfarbe weiterschalten
lWoche = lWoche + 1
End If
Else
->Wochenende
ws.Tab.ColorIndex = cFARBE_WOCHENENDE
End If
Else
->nicht im relevanten Monat -> nicht relevant
ws.Tab.ColorIndex = cFARBE_NICHTRELEVANT
End If
End If
->Datum nächster Tag
dDateTagesBlatt = DateAdd(d, 1, dDateTagesBlatt)
Next
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing
End Sub
