Startseite

Die Makros

Diese Makros werden in ein Standardmodul kopiert. Über sie wird der Kalender erstellt und gesteuert.
Option Explicit
' geschrieben von Klaus-Dieter Oppermann
' der Kalender darf frei verwendet werden, solange mein
' Name und der Hinweis auf meine Internetseite nicht
' entfernt werden.
' Stand 03.11.2006

Sub kalender()
' Baut die Kalenderblätter auf
' Variablen deklarieren
Dim iZeile As Integer                                                           ' letzte Zeile für aktuellen Monat
Dim iSpalte As Integer                                                          ' Spalte im Kalender
Dim iAnz As Integer                                                             ' Zähler für Monat
Dim iHalbj As Integer                                                           ' Steuerung des Halbjahres
Dim iStartZei As Integer                                                        ' Startzeile für Kalendermonate
Dim iKorr As Integer                                                            ' Korrekturwert für Halbjahr (Datum)
Dim vMnLgArr As Variant                                                         ' Monatslänge (Tage)
Application.ScreenUpdating = False                                              ' Bildschirmaktualisierung aus
' Kalendarium löschen und Formate definieren
With Range("6:36,41:71")                                                        ' Löschbereiche definieren
    .ClearContents                                                              ' Bereich löschen
    .RowHeight = 16                                                             ' Zeilenhöhe definieren
    .VerticalAlignment = xlCenter                                               ' vertikale Zentrierung der Schrift
End With                                                                        ' Ende der Bearbeitung
'Cells(2, 4) = 2006
jahr                                                                            ' Unterprogramm jahr starten
verbinden                                                                       ' Unterprogramm verbinden starten
vMnLgArr = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)                ' Tageszahlen für Monate zuweisen
If Sheets("Kalender").Cells(2, 4) Mod 4 = 0 Then vMnLgArr(1) = 29               ' Korrektur für Februar in Schaltjahren
iStartZei = 6                                                                   ' Startzeile 1. Halbjahr
iKorr = 5                                                                       ' Korrektur 1. Halbjahr für Datumberechnung
For iHalbj = 1 To 2                                                             ' Halbjahr definieren
    If iHalbj = 2 Then                                                          ' wenn 2. Halbjahr, dann ...
        iStartZei = 41                                                          ' ... Startzeile neu definieren
        iKorr = 40                                                              ' ... Korrekturwert für Halbjahr neu definieren
    End If                                                                      ' Ende der Definition
' Kalendarium neu aufbauen
    For iSpalte = 1 To 16 Step 3                                                ' laufe von Spalte 3 nach Spalte 16 in dreier Sprüngen
        iAnz = iAnz + 1                                                         ' Monatszähler plus 1
        For iZeile = iStartZei To vMnLgArr(iAnz - 1) + iStartZei - 1            ' laufe von 1. bis letzter Zeile
            Sheets("Kalender").Cells(iZeile, iSpalte) = CDate(iZeile - iKorr _
            & "." & iAnz & "." & Sheets("Kalender").Cells(2, 4).Value)          ' Datum berechnen
            Sheets("Kalender").Cells(iZeile, iSpalte).NumberFormat = "DDD DD"   ' Eintrag des Datums formatieren (Mo 01)
        Next iZeile                                                             ' nächste Zeile
    Next iSpalte                                                                ' nächste Spalte
Next iHalbj                                                                     ' nächstes Halbjahr
schichten                                                                       ' Unterprogramm Schichten eintragen aufrufen
bedFormat                                                                       ' Unterprogramm bedingte Formatierungen aufrufen
feiertg                                                                         ' Unterprogramm Feiertage eintragen aufrufen
End Sub

Sub feiertg()
' trägt die vordefinierten Feiertage ins Kalendarium ein
Dim iZeile As Integer                                                           ' Zeile für Datum
Dim such As String                                                              ' Suchstring des Feiertags
Dim c                                                                           ' Zieladresse des Feiertags
Dim firstAddress                                                                ' Zieladresse des Feiertags (temporär)
For iZeile = 2 To 24                        ' MUSS NOCH DYNAMISIERT WERDEN!     ' laufe von Zeile 2 nach Zeile 24
    such = Sheets("Feiertage").Cells(iZeile, 1)                                 ' Suchdatum einlesen
With Sheets("Kalender").Range("A1:P71")                                         ' Suchbereich festlegen
    Set c = .Find(CDate(such), LookIn:=xlFormulas, LookAt:=xlWhole)             ' Suche starten
    If Not c Is Nothing Then                                                    ' wenn Treffer, dann ...
        firstAddress = c.Address                                                ' ... Adresse an temp. Variable übergeben
        Sheets("Kalender").Cells(c.Row, c.Column + 2) = _
            Sheets("Feiertage").Cells(iZeile, 2)                                ' ... Feiertag eintragen
    End If                                                                      ' Ende Eintrag
End With                                                                        ' Ende Suche
Next iZeile                                                                     ' nächste Suche starten
End Sub

Sub schichten()
' trägt vorgegebene Schichtkürzel in einen Kalender ein
' geschrieben von Klaus-Dieter Oppermann
' am 16.03.2004
' letzte Änderung 28.11.2004    ' Korrektur für Schaltjahr zugefügt
' Änderung 28.10.2006           ' geänderte Ausgabe der Halbjahre
' Variablen deklarieren
Dim sk As Variant               ' Schichtkürzel
Dim vKoArr As Variant           ' Korrekturwerte
Dim s As Integer                ' Schleifenzähler für Tabellenzeilen
Dim we As Integer               ' Zuweisungsschlüssel
Dim sp As Integer               ' Schleifenzähler für Spalten
Dim arr(50, 0)                  ' Array zum Eintragen der Kürzel
Dim ziel As Integer             ' letzte Zelle für Array
Dim iHalbj                      ' Halbjahr
Dim iZei As Integer             ' Zeilenbezug Zielzeile
Dim iSta As Integer             ' Zeilenbezug Startzeile
Dim iSchiKorr As Integer        ' Schichtkorrektur
Dim Schi As Integer             ' Arrayfeld für Schichtkorrektur
' Schichbezeichnungen in Feldvariable einlesen
sk = Array("S", "S", "N", "N", "-", "-", "F", _
"F", "F", "S", "S", "N", "N", "-", "-", "-", _
"F", "F", "S", "S", "N", "N", "N", "-", _
"-", "F", "F", "S")                                                     ' Schichtbezeichnungen
vKoArr = Sheets("Schichtfolge").Range("B35:AC38").Value2                ' Korrekturwerte einlesen
iZei = 37                                                               ' Zielzeile definieren
iSta = 6                                                                ' Startzeile definieren
' Korrekturen für verschiedene Schichten festlegen
Select Case Sheets("Kalender").Cells(3, 1)                              ' Gewählte Schicht ermitteln
    Case "Schicht 1"                                                    ' Wenn Schicht A, dann ...
        Schi = 1                                                        ' ... Arraybereich 1
    Case "Schicht 2"                                                    ' wenn Schicht B, dann ...
        Schi = 2                                                        ' ... Arraybereich 3
    Case "Schicht 3"                                                    ' wenn Schicht C, dann ...
        Schi = 3                                                        ' ... Arraybereich 2
    Case "Schicht 4"                                                    ' wenn Schicht D, dann ...
        Schi = 4                                                        ' ... Arraybereich 4
End Select                                                              ' Ende der Festlegung
' Kürzel in Kalender schreiben
For iHalbj = 1 To 2                                                     ' Halbjahr definieren
    If iHalbj = 2 Then                                                  ' wenn 2. Halbjahr, dann ...
        iZei = 71                                                       ' ... Zielzeile ändern
        iSta = 41  '40                                                     ' ... Startzeile ändern
    End If                                                              ' Ende
    For sp = 2 To 17 Step 3                                             ' Schleife für Spaltenzuweisung
        ziel = Sheets("Kalender").Cells(iSta, sp - 1).End(xlDown).Row   ' Zielwert für Schleife
'        If sp = 5 And cells(1,4) Mod 4 <> 0 Then ziel = ziel - 1       ' Korrektur für Schaltjahr
        For s = 0 To ziel - iSta                                        ' Schleife für Einträge in Zeilen
            we = Sheets("Kalender").Cells(s + iSta, sp - 1) Mod 28      ' Feldwert für Variable berechnen
           iSchiKorr = we - vKoArr(Schi, we + 1)                        ' Arrayfeld aus Datum und Schicht berechnen
           arr(s, 0) = sk(iSchiKorr)                                    ' Neue Inhalte in Array einlesen
        Next s                                                          ' Schleifenzähler (Zeile) plus 1
        Range(Sheets("Kalender").Cells(iSta, sp), Sheets("Kalender") _
        .Cells(ziel, sp)) = arr                                         ' Array in Tabelle schreiben
        Erase arr                                                       ' Array löschen
    Next sp                                                             ' Schleifenzähler (Spalte) plus 1
    If Cells(1, 4) Mod 4 <> 0 Then Sheets("Kalender").Cells(34, 5) = "" ' Korrektur für Schaltjahr
Next iHalbj
End Sub

Sub bedFormat()
' fügt bedingte Formte ein
Dim meinBereich As Range
Dim meinBereich2 As Range
Set meinBereich = Sheets("Kalender").Range("A6:A36,D6:D34,G6:G36,J6:J35,M6:M36,P6:P35,A41:A71,A41,D41:D71,G41:G70,J41:J71,M41:M70,P41:P71") '.Select
Set meinBereich2 = Sheets("Kalender").Range("C6:C36,F6:F34,I6:I36,L6:L35,O6:O36,R6:R35,C41:C71,F41:F71,I41:I70,L41:L71,O41:O70,R41:R71")
meinBereich.Select
With meinBereich
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=LÄNGE(C6)>1"
    .FormatConditions(1).Font.Bold = True
    .FormatConditions(1).Font.ColorIndex = 3
    ' Datumspalten
    .HorizontalAlignment = xlRight
    .EntireColumn.AutoFit
End With
With meinBereich
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=WOCHENTAG(A6)=1"
    .FormatConditions(2).Font.Bold = True
    .FormatConditions(2).Font.ColorIndex = 2
    .FormatConditions(2).Interior.ColorIndex = 5
End With
With meinBereich
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=UND(WOCHENTAG(A6)=7;LÄNGE(A6)>0)"
    .FormatConditions(3).Font.Bold = True
    .FormatConditions(3).Font.ColorIndex = 2
    .FormatConditions(3).Interior.ColorIndex = 10
End With
meinBereich2.Select
With meinBereich2
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=LÄNGE(C6)>1"
    .FormatConditions(1).Font.Bold = True
    .FormatConditions(1).Font.ColorIndex = 3
End With
Cells(1, 1).Select
With Range("B2,E2,H2,K2,N2,Q2")
    .ColumnWidth = 2
End With
With Range("C2,F2,I2,L2,O2,R2")
    .ColumnWidth = 18
End With
With Range("B:C,E:F,H:I,K:L,N:O,Q:R")
    .HorizontalAlignment = xlCenter
End With
Range("A38:R40").HorizontalAlignment = xlCenter
End Sub

Sub jahr()
Dim KopfBer1(2) As Range
Dim KopfBer2(2) As Range
Dim KopfBer3(2) As Range
Dim iKB As Integer
Dim iAgZei As Integer
Set KopfBer1(1) = Sheets("Kalender").Range("D2:R2")
Set KopfBer1(2) = Sheets("Kalender").Range("D37:R37")
Set KopfBer2(1) = Sheets("Kalender").Range("A3:R4")
Set KopfBer2(2) = Sheets("Kalender").Range("A38:R39")
Set KopfBer3(1) = Sheets("Kalender").Range("A2:C2")
Set KopfBer3(2) = Sheets("Kalender").Range("A37:C37")
For iKB = 1 To 2
If iKB = 2 Then iAgZei = 35
With KopfBer1(iKB)
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
    .Font.Bold = True
    .Font.Name = "Arial"
    .Font.Size = 14
    .MergeCells = True
End With
With KopfBer2(iKB)
Sheets("Kalender").Cells(3 + iAgZei, 1) = "Schicht 1"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Bold = True
    .Font.Name = "Arial"
    .Font.Size = 14
    .MergeCells = True
End With
With KopfBer3(iKB)
    .MergeCells = True
End With
Next iKB
End Sub

Sub verbinden()
Dim iVerbSp As Integer
Dim vMonArr As Variant
Dim iMAnz As Integer
Dim iWe As Integer
Dim iHalbJahr As Integer
Dim iStaZeil As Integer
vMonArr = Array("Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember")
iStaZeil = 5
For iHalbJahr = 1 To 2
If iHalbJahr = 2 Then iStaZeil = 40
For iVerbSp = 1 To 16 Step 3
    Range(Sheets("Kalender").Cells(iStaZeil, iVerbSp), Sheets("Kalender").Cells(iStaZeil, iVerbSp + 2)).Merge
    Sheets("Kalender").Cells(iStaZeil, iVerbSp) = vMonArr(iMAnz)
    With Cells(iStaZeil, iVerbSp)
        .Font.Name = "Arial"
        .Font.Size = 12
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    iMAnz = iMAnz + 1
    If iVerbSp Mod 2 = 0 Then Sheets("Kalender").Cells(iStaZeil, _
    iVerbSp).Interior.ColorIndex = 15 Else Sheets("Kalender") _
    .Cells(iStaZeil, iVerbSp).Interior.ColorIndex = 35
Next iVerbSp
Next iHalbJahr
End Sub

Sub Formular_oeffnen()
Schichtkalender.Show
End Sub

Sub KalOeffnen()
kalender.Activate
End Sub

Code eingefügt mit: Excel Code Jeanie