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
Formel Lösung.xlsx (Größe: 56,89 KB / Downloads: 3)
