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.
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
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
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.
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.
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?
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.
10.06.2023, 12:21 (Dieser Beitrag wurde zuletzt bearbeitet: 10.06.2023, 12:21 von 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
10.06.2023, 12:49 (Dieser Beitrag wurde zuletzt bearbeitet: 10.06.2023, 12:55 von 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
Kalender Schichten automatisch eintragen
