Fast
Erst mal herzlichen Dank für dein Support. Das Ziel ist greifbar.......
-Peter führt ein Eigenleben und erschein immer zu unterst. Die Reihenfolge in O soll gleich sein wie in B. B ist Massgebend
-Habe in B und D mal die maximale Anzahl von Werten eingetragen die ich haben werde. 10 Aktionszeiten, 15 Kollegen. Die beiden Anzahlen können von Tag zu Tag variieren
-In F:G habe ich mal noch ein paar Ausnahmen eingefügt, die leider nicht übernommen werden.
>zB dürfte Hans keinen Aktion für 09:00 erhalten.
>Trage ich zB Helmut um 08:30 als nicht Verfügbar ein, wird dieser noch nicht mal in O ausgeführt
-AT-AY werden Daten ins Leere geschrieben
Habe nochmal die datei angehänt damit die Bug's nachvollziehen kannst
Wenn ich das Makro in einer andere Datei verschieben möchte, was muss ich beachten?
habe die Datei geladen, muss mir die Fehler noch anschauen. Zur Makro Frage:
Unter der Voraussetzung das Tabellenname und alle Spalten wie im Beispiel gleich bleiben kannst du das Makro ohne eine Aenderung in deine Datei kopieren. Einfach in ein normales Modul. Das wars. Angepasst werden muss es nur wenn sich in den Spalten etwas verschiebt.
hier ein überarbeitets Makro das die gewünschten Optionen berücksichtigt. Ich hoffe es klappt diesmal einwandfrei.
Dem Button bitte den neuen Makro Namen zuweisen, entweder über Dialog, oder indem man das untere Makro startet. Ich bin gespannt ...
mfg Gast 123
Code:
Option Explicit '8.12.2018 für Clevber Forum Gast 123
Const Spamax = 51 'max. Spalte 51 = "AW" in Tabelle
'Spielplan und Kollegen Verteilung auswerten
Sub Kollegen_auswerten_4()
Dim rfind As Range, lzA, lzF
Dim AC As Range, a, d, m, j
With Worksheets(1)
lzA = .Cells(Rows.Count, 1).End(xlUp).Row
lzF = .Cells(Rows.Count, 6).End(xlUp).Row
a = 2: d = 2: m = 3 'Zaehler Vorgaben
'Spielplan und Spalte K löschen
.Range("O3:AW" & lzA + 2).ClearContents
.Range("M2:M" & lzA + 2).ClearContents
Application.ScreenUpdating = False
'Verfügbarkeit der Kollegen auswerten Spalte K
For Each AC In .Range("I2", .[I2].End(xlDown))
'Verfügbarkeit prüfen
For j = 2 To lzF
If CDate(AC) = CDate(.Cells(j, 7)) Then _
If .Cells(a, 2) = .Cells(j, 6) Then a = a + 1
If a > lzA 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 > lzA Then a = 2
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 Spamax '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 lzA + 1
If .Cells(AC.Row, "M") = .Cells(m, "O") Then Exit For
Next m
'Aktion + Bemerkung in Plan einfügen
AC.Cells(1, 2).Resize(1, 3).Copy
.Cells(m, d).PasteSpecial xlPasteValues
Next AC
Range("M2").Select
End With
End Sub
Sub zuweisen()
ActiveSheet.Shapes(1).OnAction = "Kollegen_auswerten_4"
End Sub
-Habe ich Helmut um 08:30 und um 16:00 nicht verfügbar wird in Helmut in O gar nicht eingefügt
-Ist auch Hans um 09:00 nicht verfügbar dann erscheint er auch nicht mehr in O
-Weiter hinten stimmt die Zuteilung auch irgendwie nicht ganz. zB AK18. Sackhüpfen um 16:00 steht irgendwo unten im Schilf.
-In Reihe 12 stehen Aktionen aber eben kein Kollege bzw habe ich im Beispiel 11 Kollegen aber es werden nur 9 in O aufgeführt
Darf ich dich hoffentlich ein letztens Mal bemühen? Wäre Hammer wenn das funktionieren würde
die dummen kleinen Flüchtigkeitsfehler, aber sie haben fatale Wirkung! Zwei Zeilen must du im Code aendern:
Hinter der With Klammer die lzA Zeile wie unten, und vor Next K - "Application.CutCopyMode" - neu einfügen! Dann sollte es klappen.
Zur Begründung: ich suchte die letzte Zelle für Kollegen in Spalte A statt Spalte B. Dort steht aber deine Lauf-Nr von 1-15! Spalte B ist aber nicht bis 15 ausgefüllt. Das Mako begriff nicht das es Leere Zellen nach M und O kopierte! Computer sind eben dumm, sie befolgen sturheil ihre Befehle. Schau bitte ob es jetzt klappt ...
mfg Gast 123
Code:
With Worksheets(1)
lzA = .Cells(Rows.Count, 2).End(xlUp).Row
11.12.2018, 11:52 (Dieser Beitrag wurde zuletzt bearbeitet: 11.12.2018, 13:18 von WillWissen.
Bearbeitungsgrund: Codetags
)
Danke
Das mit dem "lzA = .Cells(Rows.Count, 2).End(xlUp).Row" habe ich hinbekommen aber ich sehe kein "Next K" bzw weiss nicht wo ich Application.CutCopyMode = False
Next AC
---einfügen soll
Code:
Option Explicit '8.12.2018 für Clevber Forum Gast 123
Const Spamax = 51 'max. Spalte 51 = "AW" in Tabelle
'Spielplan und Kollegen Verteilung auswerten
Sub Kollegen_auswerten_4()
Dim rfind As Range, lzA, lzF
Dim AC As Range, a, d, m, j
With Worksheets(1)
lzA = .Cells(Rows.Count, 2).End(xlUp).Row
lzF = .Cells(Rows.Count, 6).End(xlUp).Row
a = 2: d = 2: m = 3 'Zaehler Vorgaben
'Spielplan und Spalte K löschen
.Range("O3:AW" & lzA + 2).ClearContents
.Range("M2:M" & lzA + 2).ClearContents
Application.ScreenUpdating = False
'Verfügbarkeit der Kollegen auswerten Spalte K
For Each AC In .Range("I2", .[I2].End(xlDown))
'Verfügbarkeit prüfen
For j = 2 To lzF
If CDate(AC) = CDate(.Cells(j, 7)) Then _
If .Cells(a, 2) = .Cells(j, 6) Then a = a + 1
If a > lzA 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 > lzA Then a = 2
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 Spamax '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 lzA + 1
If .Cells(AC.Row, "M") = .Cells(m, "O") Then Exit For
Next m
'Aktion + Bemerkung in Plan einfügen
AC.Cells(1, 2).Resize(1, 3).Copy
.Cells(m, d).PasteSpecial xlPasteValues
Next AC
Range("M2").Select
End With
End Sub
Sub zuweisen()
ActiveSheet.Shapes(1).OnAction = "Kollegen_auswerten_4"
End Sub
Option Explicit '8.12.2018 für Clevber Forum Gast 123
Const Spamax = 51 'max. Spalte 51 = "AW" in Tabelle
'Spielplan und Kollegen Verteilung auswerten
Sub Kollegen_auswerten_4()
Dim rfind As Range, lzA, lzF
Dim AC As Range, a, d, m, j
With Worksheets(1)
llzA = .Cells(Rows.Count, 2).End(xlUp).Row
lzF = .Cells(Rows.Count, 6).End(xlUp).Row
a = 2: d = 2: m = 3 'Zaehler Vorgaben
'Spielplan und Spalte K löschen
.Range("O3:AW" & lzA + 2).ClearContents
.Range("M2:M" & lzA + 2).ClearContents
Application.ScreenUpdating = False
'Verfügbarkeit der Kollegen auswerten Spalte K
For Each AC In .Range("I2", .[I2].End(xlDown))
'Verfügbarkeit prüfen
For j = 2 To lzF
If CDate(AC) = CDate(.Cells(j, 7)) Then _
If .Cells(a, 2) = .Cells(j, 6) Then a = a + 1
If a > lzA 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 > lzA Then a = 2
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 Spamax '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 lzA + 1
If .Cells(AC.Row, "M") = .Cells(m, "O") Then Exit For
Application.CutCopyMode = False
Next m
'Aktion + Bemerkung in Plan einfügen
AC.Cells(1, 2).Resize(1, 3).Copy
.Cells(m, d).PasteSpecial xlPasteValues
Next AC
Range("M2").Select
End With
End Sub
Sub zuweisen()
ActiveSheet.Shapes(1).OnAction = "Kollegen_auswerten_4"
End Sub
ja, ja, die dummen kleinen Flüchtigkeitsfehler. Die Variable lzA war mit doppel "LL" geschrieben, als "llzA". Das gibt Error wegen falscher Variable!
Die Application habe ich weiter nach unten gesetzt, vor Next AC. Probier bitte mal ob es jetzt klappt.
mfg Gast 123
Code:
Option Explicit '8.12.2018 für Clevber Forum Gast 123
Const Spamax = 51 'max. Spalte 51 = "AW" in Tabelle
'Spielplan und Kollegen Verteilung auswerten
Sub Kollegen_auswerten_5()
Dim rfind As Range, lzA, lzF
Dim AC As Range, a, d, m, j
With Worksheets(1)
lzA = .Cells(Rows.Count, 2).End(xlUp).Row
lzF = .Cells(Rows.Count, 6).End(xlUp).Row
a = 2: d = 2: m = 3 'Zaehler Vorgaben
'Spielplan und Spalte K löschen
.Range("O3:AW" & lzA + 2).ClearContents
.Range("M2:M" & lzA + 2).ClearContents
Application.ScreenUpdating = False
'Verfügbarkeit der Kollegen auswerten Spalte K
For Each AC In .Range("I2", .[I2].End(xlDown))
'Verfügbarkeit prüfen
For j = 2 To lzF
If CDate(AC) = CDate(.Cells(j, 7)) Then _
If .Cells(a, 2) = .Cells(j, 6) Then a = a + 1
If a > lzA 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 > lzA Then a = 2
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 Spamax '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 lzA + 1
If .Cells(AC.Row, "M") = .Cells(m, "O") Then Exit For
Next m
'Aktion + Bemerkung in Plan einfügen
AC.Cells(1, 2).Resize(1, 3).Copy
.Cells(m, d).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next AC
