ich habe dein letztes Beispiel zweimal runtergeladen, kann aber keinen Fehler feststellen. Es gibt in der Auswertung keinen Überlauf, und die Reihenfolge der Kollegen stimmt m.E. überein. Um 7:00 ist Alain als letzter an der Reihe, dann geht es um 8:00 Uhr mit Marc weiter. Marc ist ja nur um 7:00 nicht verfügbar! Bei neun Aktionen kommt er um 7:00 ja nicht mehr zum Einsatz! Um 8:00 ist er verefügbar.
Die weitere Auswertung ist gneau und exakt nach der Kollegen Aufstellung. Welchen Fehler meinst du konkret, oder war das die falsche Datei???
wo genau startet das Makro für den Button in der "Erfassung"? Eins befindet sich im Modul1, das ich zum Testen bevorzuge, und eins ist in der Tabelle "Speilplan" integriert. Welches Makro startest du, wurden beide auf den neuesten Stand gebracht??
Zitat:Um 7:00 ist Alain als letzter an der Reihe, dann geht es um 8:00 Uhr mit Marc weiter. Marc ist ja nur um 7:00 nicht verfügbar!
Bei neun Aktionen kommt er um 7:00 ja nicht mehr zum Einsatz! Um 8:00 ist er verefügbar.
Nicht verfügbar ist gleichzustellen wie eine Aktion erhalten. D.H Marc ist um 0700 als erster keinen Job erhalten, aber da er sich eben ausgetragen hat=nicht verfügbar, zählt dies in diesem Fall wie eine Aktion erhalten. Somit müsste in diesem speziellen Fall eben wieder Martin als Nr1 den ersten Job erhalten. Gruss Enzo
ich habe das Makro noch einmal korrigiert, im Überlauf die Schleife Verfügbarkeit mit eingebaut. Hoffe das es so euren Wünschen entspricht. Für mich ist das die letzte Aenderung, verabschiede mich aus diesem Thread. Wenn noch Fragen sind bitte an die Kolegen wenden.
Ich wünsche euch allen ein frohes neues Jahr ...
mfg Gast 123
Code:
Option Explicit '8.12.2018 für Clevber Forum Gast 123
Const ZÜberlauf = 21 '1. Zeile für Überlauf, z.Zt. 22 Const Passwort = "Enzo" 'Passwort bitte selbst festlegen
'Korrektur 18.12.2018 - 23.12.2018 - 2.1.2019 'Korrektur 29.1.22018 MTA weiterzaehlen!! (nicht verfügbar=Aktion erhalten) 'Spielplan und Kollegen Verteilung auswerten
Sub Kollegen_auswerten_6() Dim rfind As Range, lzB, lzF, lzEf Dim AC As Range, a, d, m, j, ü, z, Txt Dim EFS As Worksheet, Spmax As Integer Set EFS = Worksheets("Erfassung") 'GoTo Start 'No InputBox
'** falss Passwort nicht erwünscht diesen Teil löschen Txt = InputBox("Stimmen alle Daten in der Erfassung?" & Chr(10) & _ "Soll der Spielplan jetzt erstellt werden?" & Chr(10) & _ Chr(10) & "Bitte das Passwort eingeben!") If Txt = Empty Then Exit Sub If Txt <> Passwort Then MsgBox "Falsches Passwort": Exit Sub '** Ende des Passwort Code
Start: With Worksheets("Spielplan") Application.ScreenUpdating = False Spmax = .Cells(2, Columns.Count).End(xlToLeft).Column
'Spielplan und Spalte K löschen (Spielplan 200 Zeilen nach unten) .Range("A2:M200").ClearContents 'erweitert auf 200!! .Range("O3").Resize(100, Spmax).ClearContents .Range("N3").Resize(100, 1).ClearContents
'### Kollegen aus Spalt P nach K kopieren If Trim(EFS.Range("P1")) <> "" Then 'neu eingefügt EFS.Range("K2:K20").ClearContents 'zuerst K Bereich löschen For j = 1 To 20 'Daten ohne Leerzeilen!! If Trim(EFS.Cells(j, "P")) = Empty Then Exit For EFS.Cells(j + 1, "K") = EFS.Cells(j, "P") Next j Else: MsgBox "Erfassung Spalte P nicht kopiert - 1. Zelle leer!" End If '#### Ende neuer Teil
'Daten aus Erfassung in Spielplan kopieren (keine Formeln!) lzEf = EFS.Cells(Rows.Count, 2).End(xlUp).Row
'Ausnahmen -Ohne Leerzellen- kopieren !! For j = 2 To EFS.Range("M1").End(xlDown).Row If Trim(EFS.Cells(j, "M")) = Empty Then Exit For .Cells(j, "F") = EFS.Cells(j, "M") .Cells(j, "G") = EFS.Cells(j, "N") Next j Application.CutCopyMode = False '** Ende Kopier Teil: Daten in Spielplan kopieren
lzB = .Cells(Rows.Count, 2).End(xlUp).Row lzF = .Cells(Rows.Count, 6).End(xlUp).Row a = 2: d = 2: m = 3: ü = 0 'Zaehler Vorgaben z = 2
On Error Resume Next 'Verfügbarkeit der Kollegen auswerten Spalte K For Each AC In .Range("I2", .[I2].End(xlDown)) If Trim(AC) = Empty Then Exit For 'Nullwert!! 'Überlauf Zaehler bei neeur Uhrzeit löschen If AC.Row > 2 And Format(CDate(AC), "hh:mm") = _ Format(CDate(AC.Cells(0, 1)), "hh:mm") Then Else: ü = 0: Txt = Empty End If
If ü + 1 < lzB Then 'Verfügbarkeit prüfen (auf Nullwerte prüfen!!) For j = 2 To lzF If Trim(.Cells(j, 6)) = Empty Then Exit For If Abs(AC.Value - .Cells(j, 6)) < 0.0001 Then If .Cells(a, 2) = .Cells(j, 7) Then Txt = Txt & ", " & .Cells(a, 2) a = a + 1 End If If a > lzB Then a = 2 End If Next j
'Kollegen Überlauf Prüfung bei Nicht Verfügbar!! If InStr(Txt, .Cells(a, 2)) Then GoTo übL
'Kollegen in Spalte K eintragen AC.Offset(0, 4) = .Cells(a, 2) Txt = Txt & ", " & .Cells(a, 2) a = a + 1 'Next Kollege in K If a > lzB Then a = 2
ü = ü + 1 'Überlauf Zaehler +1 Else 'Überlauf Vorgabe Zeile 21: übL: .Cells(21, "O") = "Überlauf:" ü = ZÜberlauf 'geaend. 2.1.2019 'Verfügbarkeit auch bei Überlauf prüfen For j = 2 To lzF If Trim(.Cells(j, 6)) = Empty Then Exit For If Abs(AC.Value - .Cells(j, 6)) < 0.0001 Then If .Cells(a, 2) = .Cells(j, 7) Then Txt = Txt & ", " & .Cells(a, 2) a = a + 1 End If If a > lzB Then a = 2 End If Next j End If Next AC
'Kollegen gemaess Spalte B in Spalte O auflisten a = 3 '1.Zeile im Plan For j = 2 To .Cells(1, 2).End(xlDown).Row For Each AC In .Range("M2", .[m2].End(xlDown)) If .Cells(j, 2) = AC.Value Then .Cells(a, "O") = .Cells(j, 2) a = a + 1: Exit For End If Next AC Next j
'Spiele den Zeiten und Kollegen zuordnen For Each AC In .Range("I2", .[I2].End(xlDown)) If AC.Formula <> AC.Cells(0, 1).Formula Then ü = ZÜberlauf
For d = 16 To Spmax Step 3 '45 Spalten von P-AS If Abs(AC.Value - .Cells(2, d)) < 0.0001 Then Exit For Next d
'definierte Zeit im Plan suchen (Zeile 2) For m = 3 To lzB + 1 If .Cells(AC.Row, "M") = .Cells(m, "O") Then Exit For Next m
'Aktion + Bemerkung in Plan einfügen If AC.Offset(0, 4) <> Empty Then AC.Cells(1, 2).Resize(1, 3).Copy .Cells(m, d).PasteSpecial xlPasteValues Application.CutCopyMode = False Else 'oder als Überlauf notieren AC.Cells(1, 2).Resize(1, 3).Copy .Cells(ü, d).PasteSpecial xlPasteValues Application.CutCopyMode = False ü = ü + 1 'Next Überlauf End If
Next AC End With
'Tabelle Endprodukt aktivieren 'Worksheets("Endprodukt").Select End Sub