Kalender Schichten automatisch eintragen

[Fränky]

Hallo,
ich brauche euere Hilfe. Habe einen Schichtkalender angefertigt bei dem ein bestimmter Schichtrhythmus per Button für jeden Mitarbeiter einzeln in den gesamten Kalender eingetragen werden soll. Durch ein `x` wird der Mitarbeiter ausgewählt. Habe für jeden Mitarbeiter einen 4 Wochen Rhythmus erstellt. Es soll ab dem Startdatum, welches man eingeben kann, die Schichten eingetragen werden. Des weiteren soll die mit `x` makierte Schicht mit der Eintragung starten. Ich hoffe das ist einigermaßen verständlich. Habe schon versucht aus anderen Schichtkalendern mir einen VBA Code zu basteln aber bin dann schnell an meine Grenzen geraten. Habe die Datei angehängt und hoffe es kann mir jemand helfen.

Liebe Grüße

Fränky

[Egon12]

Hallo Fränky,

wenn ich es richtig verstanden habe, dann so:

Code:

Sub SchichtenUebergeben()
    Dim iEnde&, i&, xZ&, xS&
    With Tabelle5
        For i = 10 To 96
            If .Cells(i, 2) = "x" Then xZ = i
        Next i
        For i = 3 To 30
            If .Cells(9, i) = "x" Then xS = i
        Next i
        For i = 30 To 3 Step -1
            If .Cells(xZ, i) <> "" Then
                iEnde = i
                Exit For
            End If
        Next i
        For i = 33 To 400
            If .Cells(6, 13) = .Cells(8, i) Then
                .Range(.Cells(xZ, xS), .Cells(xZ, iEnde)).Copy
                .Cells(xZ, i).PasteSpecial xlPasteValues
            End If
        Next i
    End With
End Sub

Gruß Uwe

[Fränky]

Hallo Uwe
das ist auf jeden Fall schon mal ein guter Anfang. Die Schichten sollen aber fortlaufend bis Spalte OH eingetragen werden (OH bei einem Schaltjahr, sonst bis OG). werden jetzt nur 4 Wochen eingetragen. Wenn ich das Jahr ändere wird leider nichts mehr eingetragen. Aber vielen Dank schon mal.
Grüße 
Fränky

[Egon12]

Hallo Fränky,

in Zeile:

Code:

If .Cells(6, 13) = .Cells(8, i) Then

werden das Startdatum mit dem Datum der Zeile 8 ab Spalte "AG" auf Gleichheit geprüft. Da ist es egal welches Jahr. Entweder es wird ein gleiches Datum gefunden oder nicht.
Wenn da natürlich Text gegen Datum steht, ist kein Gleichnis vorhanden.
Man kann dies natürlich mit entsprechender Behandlung erzwingen:

Code:

If CDate(.Cells(6, 13)) = CDate(.Cells(8, i)) Then

Was das Schaltjahr anlangt, ändere die ... to 400 entsprechend um.
Fehlerbehandlung kannst du bestimmt was nötig ist im Netz finden und den Erfordernissen anpassen.
Ich verwende Office 2019 und kann die Timeline nicht aus ein anderes Jahr umstellen. Mich interessiert hier eh nur VBA. Dashalb der Code ins Blaue von mir.

Gruß Uwe

[Fränky]

Hallo Uwe

mit dem Datum funktioniert jetzt, hatte tatsächlich zwei verschiedene Daten. 
Mit dem Eintragen in den Kalender klappt das noch nicht. Werden nur die ersten 4 Wochen gefüllt und nicht bis Spalte 400.

Beispiel:
           x
FFFFF--SSSSS--NNNNN--NNNNN--

Da wo das x steht soll er beginnen die Schicht am Startdatum einzutragen, was auch mit deinem Code funktioniert. Es werden dann aber auch nur 3 Wochen eingetragen also eine Wochen Spät und zwei Wochen Nacht. Die Wiederholung bis Spalte 400 klappt nicht. Es sollte dann nach den 3 Wochen der komplette Schichtrhythmus bis Spalte 400 eingetragen werden.

Dann so im Kalender:

SSSSS--NNNNN--NNNNN--FFFFF--SSSSS--NNNNN--NNNNN-- usw.

Vielen Dank für Deine Mühe Uwe

Gruß Fränky

[Sigi.21]

Hallo Fränky,

ich habe dazu noch Fragen:
Du hast 3 SchichtTypen mit je 28 Tagen. Sollen die einfach stur ab Startdatum verteilt werden?
Was ist mit Wochenenden und Feiertagen? Auch verteilen?
Was passiert bei Jahresänderung? Alles Löschen? Und neu verteilen?

Gruß Sigi

[Fränky]

Hallo Sigi

An Wochenenden wird nicht gearbeitet darum immer die zwei Leerzeichen zwischen den Schichten.
Feiertage können ignoriert werden.
Bei Jahresänderung wird, wie Du schon vermutet hast, alles gelöscht und neu verteilt, quasi soll das ein Blanko werden.

Zu den Schichttypen, es werden noch viel mehr werden aber immer über 28 Tage und ohne Wochenende. Habe jetzt zum testen nur 3 Schichttypen aufgelistet. Das Prinzip ist ja immer gleich.
Wie ich oben geschrieben habe sollen ab Startdatum nur die Schichten eingetragen werden ab der Spalte mit dem X und danach alle 28 Tage sich wiederholend bis zur Spalte 400, also der 31.12. und das auch nur für den mit X ausgewählten Mitarbeiter.
Der Code von Uwe funktioniert ja auch soweit bis auf die Wiederholungen bis zur Spalte 400.
Hoffe das ist verständlich.

Gruß Fränky

[Egon12]

Hallo,

das wäre dann so:

Code:

Sub SchichtenUebergeben()
    Dim iEnde&, i&, j&, k&, xZ&, xS&, iZz&
    With Tabelle5
        For i = 10 To 96
            If .Cells(i, 2) = "x" Then xZ = i
        Next i
        For i = 3 To 30
            If .Cells(9, i) = "x" Then xS = i
        Next i
        For i = 30 To 3 Step -1
            If .Cells(xZ, i) <> "" Then
                iEnde = i
                Exit For
            End If
        Next i
        For i = 33 To 400
            If .Cells(6, 13) = .Cells(8, i) Then
                iZz = Format((400 - i) / 28, "###")
                For j = 1 To iZz
                    .Range(.Cells(xZ, xS), .Cells(xZ, iEnde)).Copy
                    .Cells(xZ, i + k * 28).PasteSpecial xlPasteValues
                    k = (k + 1)
                Next j
            End If
        Next i
    End With
End Sub

Was ist an den Feiertagen. Sind Diese dienstfrei oder Feiertagsdienste.
Derzeit in dieser Prozedur als Feiertagsdienste eingepflegt.

falls dienstfrei dann so:

Code:

Sub SchichtenUebergeben()
    Dim iEnde&, i&, j&, k&, xZ&, xS&, iZz&
    With Tabelle5
        For i = 10 To 96
            If .Cells(i, 2) = "x" Then xZ = i
        Next i
        For i = 3 To 30
            If .Cells(9, i) = "x" Then xS = i
        Next i
        For i = 30 To 3 Step -1
            If .Cells(xZ, i) <> "" Then
                iEnde = i
                Exit For
            End If
        Next i
        For i = 33 To 400
            If .Cells(6, 13) = .Cells(8, i) Then
                iZz = Format((400 - i) / 28, "###")
                For j = 1 To iZz
                    .Range(.Cells(xZ, xS), .Cells(xZ, iEnde)).Copy
                    .Cells(xZ, i + k * 28).PasteSpecial xlPasteValues
                    k = (k + 1)
                Next j
            End If
            If .Cells(8, i).DisplayFormat.Interior.Color = RGB(78, 133, 216) Then
                .Cells(xZ, i) = ""
            End If
        Next i
    End With
End Sub

Gruß Uwe

[Fränky]

Hallo Uwe

Nach dem Ausführen des Codes kommt folgende Fehlermeldung

Laufzeitfehler `13`
Typen unverträglich

irgendwas mag er an dieser Zeile nicht
iZz = Format((400 - i) / 28, "###")

[Egon12]

so ich hab das geaddel zum einfügen in die Zeile entfernt und das Ganze in ein Array gepackt.

Code:

Sub SchichtenUebergeben()
    Dim iEnde&, i&, j&, k&, xZ&, xS&, arrMA()
    With Tabelle5
        For i = 10 To 96
            If .Cells(i, 2) = "x" Then xZ = i
        Next i
        For i = 3 To 30
            If .Cells(9, i) = "x" Then xS = i
        Next i
        For i = 30 To 3 Step -1
            If .Cells(xZ, i) <> "" Then
                iEnde = i
                Exit For
            End If
        Next i
        For i = 33 To 400
            If .Cells(6, 13) = .Cells(8, i) Then
                arrMA = .Range(.Cells(xZ, xS), .Cells(xZ, iEnde)).Value
                ReDim arrTimeline(1 To 1, 1 To 400 - i)
                For j = 1 To 400 - i - 2 Step 28
                    For k = 1 To 26
                        arrTimeline(1, k + j - 1) = arrMA(1, k)
                    Next k
                Next j
                .Cells(xZ, i).Resize(UBound(arrTimeline, 1), UBound(arrTimeline, 2)) = arrTimeline
            End If
            If .Cells(8, i).DisplayFormat.Interior.Color = RGB(78, 133, 216) Then
                'falls dienstrei ansonsten auskommentieren
                .Cells(xZ, i) = ""
            End If
        Next i
    End With
End Sub

Gruß Uwe