Im Kalender bestimmte Tage markieren

  • #1
N

nok106

Bekanntes Mitglied
Themenersteller
Dabei seit
10.09.2005
Beiträge
108
Reaktionspunkte
0
Ort
Brunsbüttel
Hallo zusammen !

Gibt es hierfür eine Lösung?

Ich möchte in einem selbsterstellten Kalender, beginnend an einem xbeliebigen Tag, dann alle 20 Tage, fortlaufend weiter, das betreffende Datum farbig markieren.

Ich habe es mal mit der bedingten Formatierung versucht, aber ohne Erfolg.

Hat jemand eine Idee ob das geht und wenn ja- wie ???

Einstweilen herzlichen Dank an alle, die sich für mich bemühen.

Gruß

Odje
 
  • #2
Wie ist denn dein Kalender aufgebaut - Zeilen, Spalten, Inhalt ...

Gruß Matjes :)
 
  • #4
Hallo nok106,

also wieder ein Makro  ;D  . Das Makro zum Farbe-Löschen als Zugabe.
Als Farbe ist knallgelb (6) eingestellt. Einen Farbauswahl-Dialog hab ich mir verkniffen  ;D

zu
..., das betreffende Datum  farbig markieren.
Zum Vergrößern anklicken....
Deine Wochenenden sind mit bedingter Formatierung farblich hinterlegt. Die bedingte Formatierung gewinnt gegen den tatsächlichen Farbhintergrund. Deshalb hab ich alle 3 Zellen eine Tages farblich hinterlegt.

Pack das ganze in ein extra Modul.

Gruß Matjes :)
Code: 
Option Explicit

Private Const cSP_ERSTEDATUMSSPALTE = 1 ->A
Private Const cSP_ANZAHL_PROMONAT = 3
Private Const cZ_ERSTEZEILE = 6
Private Const cZ_LETZTEZEILE = cZ_ERSTEZEILE + 30
Private Const cTAGE_ALLE20 = 20
Private Const cMONATE_ANZAHL = 12
Private Const cFARBINDEX = 6->tiefgelb
'**********************************************************************************
Sub FarbeInteriorLoeschen()
  Dim ws As Worksheet
  Dim z As Long, sp As Long
  Set ws = ActiveSheet
  For sp = cSP_ERSTEDATUMSSPALTE To cSP_ERSTEDATUMSSPALTE + (cSP_ANZAHL_PROMONAT * (cMONATE_ANZAHL)) - 1
    For z = cZ_ERSTEZEILE To cZ_LETZTEZEILE
      If ws.Cells(z, sp).Interior.ColorIndex = cFARBINDEX Then
        ws.Cells(z, sp).Interior.ColorIndex = xlColorIndexNone
      End If
    Next
  Next
  Set ws = Nothing
End Sub

'**********************************************************************************
Sub Alle20TageFarbeInteriorSetzen()
 ->*** Voraussetzung: eine Datumszelle ist markiert
 ->***
 ->*** Für diese Datumszelle und die Datumszellen im Abstand 19 Tage
 ->*** (also alle 20 Tage) wird her Zellehintergrung auf die ausgesuchte Farbe gesetzt
 ->***
  
  Dim ws As Worksheet
  Dim lZStart As Long, lSPStart As Long, lSPmax As Long
  Dim bIstDatumSP As Boolean, sp As Long, z As Long
  Dim sTxt As String, lCIndex As Long, lTZ As Long
  
  Set ws = ActiveSheet
  
 ->Eine Zelle markiert ?
  If Selection.Count <> 1 Then MsgBox Bitte nur eine Zelle markieren.: GoTo AUFRAEUMEN
  
 ->Datumszelle Zeile, Spalte
  lZStart = Selection.Row: lSPStart = Selection.Column
  
 ->Zeile prüfen
  If (lZStart < cZ_ERSTEZEILE) Or (lZStart > cZ_LETZTEZEILE) Then
    MsgBox Bitte eine Datums-Zelle selektieren.: GoTo AUFRAEUMEN
  End If
  
 ->Spalte prüfen
  bIstDatumSP = False
  For sp = cSP_ERSTEDATUMSSPALTE _
           To cSP_ERSTEDATUMSSPALTE + (cSP_ANZAHL_PROMONAT * (cMONATE_ANZAHL - 1)) _
           Step cSP_ANZAHL_PROMONAT
    If sp = lSPStart Then bIstDatumSP = True: Exit For
  Next
  If Not bIstDatumSP Then MsgBox Bitte eine Datums-Zelle selektieren.: GoTo AUFRAEUMEN

 ->Zelle prüfen
  If Not IsDate(ws.Cells(lZStart, lSPStart).Value) Then
    MsgBox Bitte eine Datums-Zelle mit Datum selektieren.: GoTo AUFRAEUMEN
  End If
  
 ->*** ist Datumszelle, also kann es jetzt losgehen
  lCIndex = cFARBINDEX
 ->Startzelle farbig, Tagezähler auf 1
  With ws.Cells(lZStart, lSPStart)
    .Interior.ColorIndex = lCIndex
    .Offset(0, 1).Interior.ColorIndex = lCIndex
    .Offset(0, 2).Interior.ColorIndex = lCIndex
  End With
  lTZ = 0       'Zähler Tage
  z = lZStart   'Zeile
  sp = lSPStart->Spalte
  lSPmax = cSP_ERSTEDATUMSSPALTE + (cSP_ANZAHL_PROMONAT * (cMONATE_ANZAHL - 1))
  Do
    z = z + 1
    If z > cZ_LETZTEZEILE Then
      z = cZ_ERSTEZEILE
      sp = sp + cSP_ANZAHL_PROMONAT
    End If
    If sp > lSPmax Then Exit Do
    If IsDate(ws.Cells(z, sp).Value) Then
      lTZ = lTZ + 1
      If lTZ = cTAGE_ALLE20 Then
        With ws.Cells(z, sp)
          .Interior.ColorIndex = lCIndex
          .Offset(0, 1).Interior.ColorIndex = lCIndex
          .Offset(0, 2).Interior.ColorIndex = lCIndex
        End With
        lTZ = 0
      End If
    End If
  Loop
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub
 
  • #5
Hallo Matjes,

für deine Bemühungen, um mein Anliegen zu lösen, meinen besten Dank.

Ich bewundere immer wieder dein Excelwissen und dein Können, mit dem du schon unzählige Users geholfen hast.

Ich finde es toll  :1

Gruß

Odje

Hallo Matjes,

ich möchte keinen neuen Thread anfangen, weiß aber auch nicht ob es hiermit gelingt dich nochmal ansprechen zukönnen.

Ich versuche es mal !

Frage: Ist die Möglichkeit gegeben das Makro so zu ändern, dass wenn der 20. Tag auf einen Samstag oder Sonntag fällt,  dann der vorhergehende Freitag oder der kommende Montag gekennzeichnet wird ?

Sollte es nicht möglich sein wäre es kein Beinbruch !

Mit freunlichem Gruß

Odje
 
  • #6
Hallo nok106,

ich hab beide Optionen eingebaut.  ;D

Steuern kann man das mit der Konstanten cVERSCHIEBEN (siehe Makro)

Trotz der Verschiebung wird der normale Rhythmus von 20 Tagen beibehalten.
Wenn man das nicht macht und ab dem verschobenen Tag weiterzählt, erhält man nur noch Montage bzw. Freitage.

Gruß Matjes :)
Code: 
Option Explicit

Private Const cSP_ERSTEDATUMSSPALTE = 1 ->A
Private Const cSP_ANZAHL_PROMONAT = 3
Private Const cZ_ERSTEZEILE = 6
Private Const cZ_LETZTEZEILE = cZ_ERSTEZEILE + 30
Private Const cTAGE_ALLE20 = 20
Private Const cMONATE_ANZAHL = 12
Private Const cFARBINDEX = 6->tiefgelb

Private Const cVERSCHIEBEN As Long = 2
' Trifft der Tag einen Sonnabend oder Sonntag wird der Tag verschoben,
' In Abhängigkeit der Kennung cVerschieben
' cVerschieben = 0 : keine Verschiebung
' cVerschieben = 1 : Verschieben auf den Montag danach
' cVerschieben = 2 : Verschieben auf den Freitag vorher

'**********************************************************************************
Sub FarbeInteriorLoeschen()
  Dim ws As Worksheet
  Dim z As Long, sp As Long
  Set ws = ActiveSheet
  For sp = cSP_ERSTEDATUMSSPALTE To cSP_ERSTEDATUMSSPALTE + (cSP_ANZAHL_PROMONAT * (cMONATE_ANZAHL)) - 1
    For z = cZ_ERSTEZEILE To cZ_LETZTEZEILE
      If ws.Cells(z, sp).Interior.ColorIndex = cFARBINDEX Then
        ws.Cells(z, sp).Interior.ColorIndex = xlColorIndexNone
      End If
    Next
  Next
  Set ws = Nothing
End Sub

'**********************************************************************************
Sub Alle20TageFarbeInteriorSetzen()
 ->*** Voraussetzung: eine Datumszelle ist markiert
 ->***
 ->*** Für diese Datumszelle und die Datumszellen im Abstand 19 Tage
 ->*** (also alle 20 Tage) wird her Zellehintergrung auf die ausgesuchte Farbe gesetzt
 ->***
 ->*** Trifft der Tag einen Sonnabend oder Sonntag wird der Tag verschoben,
 ->*** In Abhängigkeit der Kennung cVerschieben
 ->*** cVerschieben = 0 : keine Verschiebung
 ->*** cVerschieben = 1 : Verschieben auf den Montag danach
 ->*** cVerschieben = 2 : Verschieben auf den Freitag vorher
 ->***
 ->*** Die weitere Zählung bleibt aber bei 21 Tagen, d.h. wird der Tag verschoben
 ->*** wird der Zähler so für den nächsten zu kennzeichnenden Tag aufgesetzt,
 ->*** daß dieser von der verschiebung unberührt bleibt.
 ->*** (Wenn dies nicht erfolgt, folgen einem Montag nur noch Montage,
 ->***  einem Freitag nur noch Freitage)
  
  Dim ws As Worksheet
  Dim lZStart As Long, lSPStart As Long, lSPmax As Long
  Dim bIstDatumSP As Boolean, sp As Long, z As Long
  Dim sTxt As String, lCIndex As Long, lTZ As Long, lAnzTagVerschiebung As Long
  
  Set ws = ActiveSheet
  
 ->Eine Zelle markiert ?
  If Selection.Count <> 1 Then MsgBox Bitte nur eine Zelle markieren.: GoTo AUFRAEUMEN
  
 ->Datumszelle Zeile, Spalte
  lZStart = Selection.Row: lSPStart = Selection.Column
  
 ->Zeile prüfen
  If (lZStart < cZ_ERSTEZEILE) Or (lZStart > cZ_LETZTEZEILE) Then
    MsgBox Bitte eine Datums-Zelle selektieren.: GoTo AUFRAEUMEN
  End If
  
 ->Spalte prüfen
  bIstDatumSP = False
  For sp = cSP_ERSTEDATUMSSPALTE _
           To cSP_ERSTEDATUMSSPALTE + (cSP_ANZAHL_PROMONAT * (cMONATE_ANZAHL - 1)) _
           Step cSP_ANZAHL_PROMONAT
    If sp = lSPStart Then bIstDatumSP = True: Exit For
  Next
  If Not bIstDatumSP Then MsgBox Bitte eine Datums-Zelle selektieren.: GoTo AUFRAEUMEN

 ->Zelle prüfen
  If Not IsDate(ws.Cells(lZStart, lSPStart).Value) Then
    MsgBox Bitte eine Datums-Zelle mit Datum selektieren.: GoTo AUFRAEUMEN
  End If
  
 ->*** ist Datumszelle, also kann es jetzt losgehen
  lCIndex = cFARBINDEX
 ->Startzelle farbig, Tagezähler auf 0
  With ws.Cells(lZStart, lSPStart)
    .Interior.ColorIndex = lCIndex
    .Offset(0, 1).Interior.ColorIndex = lCIndex
    .Offset(0, 2).Interior.ColorIndex = lCIndex
  End With
  lTZ = 0       'Zähler Tage
  z = lZStart   'Zeile
  sp = lSPStart->Spalte
  lSPmax = cSP_ERSTEDATUMSSPALTE + (cSP_ANZAHL_PROMONAT * (cMONATE_ANZAHL - 1))
  Do
    z = z + 1
    If z > cZ_LETZTEZEILE Then
      z = cZ_ERSTEZEILE
      sp = sp + cSP_ANZAHL_PROMONAT
    End If
    If sp > lSPmax Then Exit Do
    If IsDate(ws.Cells(z, sp).Value) Then
      lTZ = lTZ + 1
      
      If cVERSCHIEBEN = 2 Then
       ->Wenn Sonnabend/Sonntag, dann verschieben auf den Freitag davor
       ->prüfen, ob Tag = Freitag und Zähler um 1 oder 2 vor Grenze
        If vbFriday = WeekDay(ws.Cells(z, sp).Value) Then
          If lTZ >= cTAGE_ALLE20 - 2 Then
            lAnzTagVerschiebung = lTZ - cTAGE_ALLE20
           ->Tageszähler auf Grenze setzen
            lTZ = cTAGE_ALLE20->
          End If
        End If
      End If
      
      If lTZ >= cTAGE_ALLE20 Then
        If cVERSCHIEBEN <> 1 Then
          
         ->normal behandeln
          With ws.Cells(z, sp)
            .Interior.ColorIndex = lCIndex
            .Offset(0, 1).Interior.ColorIndex = lCIndex
            .Offset(0, 2).Interior.ColorIndex = lCIndex
          End With
          lTZ = lAnzTagVerschiebung
          lAnzTagVerschiebung = 0
        Else
        
         ->wenn Sonnabend/Sonntag, dann auf Montag verschieben
          If vbSunday = WeekDay(ws.Cells(z, sp).Value) Then
           ->Sonntag -> Zähler um 1 erniedrigen
            lTZ = lTZ - 1
            lAnzTagVerschiebung = 1
          ElseIf vbSaturday = WeekDay(ws.Cells(z, sp).Value) Then
           ->Samstag -> Zähler um 2 erniedrigen
            lTZ = lTZ - 2
            lAnzTagVerschiebung = 2
          Else
           ->kein Samsatg/Sonntag -> Tag kennzeichnen
            With ws.Cells(z, sp)
              .Interior.ColorIndex = lCIndex
              .Offset(0, 1).Interior.ColorIndex = lCIndex
              .Offset(0, 2).Interior.ColorIndex = lCIndex
            End With
            lTZ = lAnzTagVerschiebung
            lAnzTagVerschiebung = 0
          
          End If
        End If
      End If
    End If
  Loop
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub
 
  • #7
Hallo Matjes,

Toll ..............  mml

Für deine Verbesserung meinen herzlichsten Dank.
Ich war im Zweifel ob mein Anliegen überhaupt machbar wäre.  ???

Aber nach deinem Motto:

Denkst du dir es geht nichts mehr -
kommt von irgendwo ein Lichtlein her ,

sollte man doch keinen Zweifel hegen.

Mit freundlichen Grüßen

Odje
 
Thema:

Im Kalender bestimmte Tage markieren

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.838
Beiträge
707.961
Mitglieder
51.491
Neuestes Mitglied
haraldmuc
Oben