ich schicke nur den neuen Code zum austauschen, keine Beispieldatei. Das kopieren von Erfassung Spalte P1:P15 nach K2:K16 habe ich programmiert, ohne zu wissen warum die Kollegen jetzt dort stehen? Der Effekt das man das Makro zweimal starten muss liegt wahrscheinlich an einer falschen Mappen Einstellung. In einer vorherigen Mappe muste ich die Automatische Berechnung abschalten, stellte sie auf Manuell. Diese Einstellung kannst du über Optionen für deine Mappe wieder auf Automatik aendern. Dann sollte das aufhören.
Das versetzen im Überlauf habe ich rausgenommen. Im Makro ist auch ein Passwort aktiviert, damit nicht jeder den Spielplan erstellen kann, Wenn du das nicht brauchst einfach den Teil im Makro löschen. Das Kennwort steht oben in der Constant Anweisung und kann beliebig geaendert werden.
Code:
Option Explicit '8.12.2018 für Clevber Forum Gast 123
Const ZÜberlauf = 22 '1. Zeile für Überlauf, z.Zt. 22
Const Passwort = "Enzo" 'Passwort bitte selbst festlegen
'Korrektur 18.12.2018
'Spielplan und Kollegen Verteilung auswerten
Sub Kollegen_auswerten_6()
Dim rfind As Range, lzB, lzF, lzEf
Dim AC As Range, a, d, m, j, ü, Txt
Dim EFS As Worksheet, Spmax As Integer
Set EFS = Worksheets("Erfassung")
'** 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
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
'### bitte prüfen obdas so richtig iat ??? 'AW vom 18.1.2018
If EFS.Range("P1").Value <> "" Then 'neu eingefügt lt. letzer AW
EFS.Range("P1:P15").Copy
EFS.Range("K2").PasteSpecial xlPasteValues
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, 1).End(xlUp).Row
EFS.Range("B2:B" & lzEf).Copy
.Range("J2").PasteSpecial xlPasteValues 'Aktionen
EFS.Range("C2:C" & lzEf).Copy
.Range("I2").PasteSpecial xlPasteValues 'Zeiten
EFS.Range("D2:E" & lzEf).Copy
.Range("K2").PasteSpecial xlPasteValues 'Material, Notizen
EFS.Range("H2", EFS.[h2].End(xlDown)).Copy
.Range("D2").PasteSpecial xlPasteValues 'definierte Zeiten
EFS.Range("J2", EFS.[k2].End(xlDown)).Copy
.Range("A2").PasteSpecial xlPasteValues 'Kolegen Liste 1-15
EFS.Range("M2", EFS.[n2].End(xlDown)).Copy
.Range("F2").PasteSpecial xlPasteValues 'Ausnahmen (nicht verfügbar)
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 'Zaehler Vorgaben
'Verfügbarkeit der Kollegen auswerten Spalte K
For Each AC In .Range("I2", .[I2].End(xlDown))
If Trim(AC) = Empty Then Exit For 'Nullwert!!
If AC.Value <> AC.Cells(0, 1) Then ü = 0
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 CDate(AC) = CDate(.Cells(j, 6)) Then _
If .Cells(a, 2) = .Cells(j, 7) Then a = a + 1
If a > lzB Then a = 2
Next j
'Kollegen in Spalte K eintragen
AC.Offset(0, 4) = .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:
.Cells(21, "O") = "Überlauf:"
ü = ZÜberlauf
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))
'definierte Zeit im Plan suchen (Zeile 2)
For d = 16 To Spmax '45 Spalten von P-AS
If AC.Value = .Cells(2, d) 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
.Cells(ü, "Q").PasteSpecial xlPasteValues
.Cells(ü, "O").Value = AC.Offset(0, 1)
.Cells(ü, "P").Value = "'" & Mid(CDate(AC), 1, 5)
Application.CutCopyMode = False
ü = ü + 1 'Next Überlauf
End If
Next AC
End With
'Tabelle Endprodukt aktivieren
Worksheets("Endprodukt").Select
End Sub
Zeile 1 wird dabei nicht berüht, wie du früher mal geschrieben hast muss diese zwingend so bleiben