VBA Hauptfarben suchen und übertragen

Hallo zusammen,
eine neue Aufgabe in meinem aktuellen Projekt, die ich definitiv nicht selbst lösen kann.
Schwer zu beschreiben, in der angehängten Datei wird es aber klar.
https://www.herber.de/bbs/user/107617.xlsm
In meiner Terminplanung gibt für jeden Mitarbeiter zuoberst eine Summenzeile, bei der je 5 Zellen (=1KW) verbunden sind und die bisher eingeplante Stundensumme angezeigt wird. Diese wird berechnet aus den darunterliegenden Zeilen, in denen die jeweils für eine Maschine pro Tag vorgesehenen Stunden eingetragen sind.
Die Mitarbeiternamen sind in Spalte D, die Maschinennummern in Spalte E. Diese Zellen in Spalte E haben zugewiesene Zellfarben (RGB) um die geht es.
Jeder Mitarbeiter hat unterschiedlich viele Maschinen usw. zu bearbeiten, deshalb auch unterschiedlich viele Zeilen, bevor es mit der Summenzeile des nächsten Mitarbeiters weitergeht. Die Zeilenzahl verändert sich auch immer wieder meistens wird unten eine Zeile hinzugefügt.
Die Teamleiter übertragen jeweils mit dem Pinsel die Farbe der jeweiligen Priorität 1-Maschine (leider manchmal auch zwei!!) auf die zugeordneten Tagesstunden (in der gleichen Zeile)
Jetzt soll ein Makro möglicherweise über einen Button auslesen:
Gibt es bei Mitarbeiter X null / eine Farbe / zwei Farben in der aktuellen Woche?
wenn null weiter zum nächsten Bereich
wenn eine diese Farbe in die verbundene Summenzelle übernehmen
wenn zwei Summe in den beiden farbigen Zeilenbereichen bilden und die Farbe des Bereichs mit der höheren Summe übernehmen. Bei gleichen Summen die Farbe der ersten (oberen) Zeile nehmen.
Dann die Summenbereiche wieder verbinden (falls durchs Kopieren der Zellverbund aufgehoben wurde).
Und das ganze über ca. 1400 Zeilen und 100 Spalten (20 Wochen)
Ist das mit vertretbarem Aufwand zu machen und würde sich jemand dieser Aufgabe annehmen?
Jetzt schon mal Danke, wenn ihr bis hier durchgehalten habt.
Beste Grüße, Margarete

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Farben_pruefen() Dim LZ As Range Dim Farbe As Long Set LZ = Sheets("Alle").UsedRange.SpecialCells(11) For i = 8 To LZ.Row If Cells(i, "F").Interior.ColorIndex xlNone Then Farbe = Cells(i, "F").Interior.Color For j = 13 To LZ.Column If Cells(i, j).Interior.ColorIndex xlNone And Cells(i, j).Interior.Color _ Farbe Then 'hier Farbe korrigieren 'Cells(i, j).Interior.Color = farbe Debug.Print Cells(i, j).Address End If Next j End If Next i End Sub

Sub MB12_Version2() Dim LZ As Range Set LZ = ActiveSheet.UsedRange.SpecialCells(11) With CreateObject("scripting.Dictionary") lr = Cells(Rows.Count, "D").End(xlUp).Row For i = 7 To lr k = Cells(i, "D") If Not .exists(k) Then .Item(k) = i End If Next i For Sp = 13 To LZ.Column Step 5 For Each k In .keys Anf = .Item(k) + 1 If IsNumeric(Cells(.Item(k), Sp)) And Cells(.Item(k), Sp) > 0 Then Do Sum = WorksheetFunction.Sum(Range(Cells(Anf, Sp), Cells(Anf, Sp).Offset(, 4))) If Sum > Sum_alt Then Sum_alt = Sum Zeile = Anf End If Anf = Anf + 1 Loop While Cells(Anf, "D") = k If Cells(.Item(k), Sp).MergeArea.Interior.Color Cells(Zeile, "F").Interior.Color _ Then Cells(.Item(k), Sp).MergeArea.Interior.Color = Cells(Zeile, "F").Interior.Color Debug.Print "geändert: " & Cells(.Item(k), Sp).MergeArea.Address End If Sum_alt = 0 End If Next k Next Sp End With End Sub

Sub MB12_Version2() Dim LZ As Range Set LZ = ActiveSheet.UsedRange.SpecialCells(11) With CreateObject("scripting.Dictionary") lr = Cells(Rows.Count, "D").End(xlUp).Row For i = 7 To lr k = Cells(i, "D") If Not .exists(k) Then .Item(k) = i End If Next i For Sp = 13 To LZ.Column Step 5 For Each k In .keys Anf = .Item(k) + 1 If IsNumeric(Cells(.Item(k), Sp)) And Cells(.Item(k), Sp) > 0 Then Do Sum = WorksheetFunction.Sum(Range(Cells(Anf, Sp), Cells(Anf, Sp).Offset(, 4))) If Sum > Sum_alt Then Sum_alt = Sum Zeile = Anf End If Anf = Anf + 1 Loop While Cells(Anf, "D") = k If Cells(.Item(k), Sp).MergeArea.Interior.Color Cells(Zeile, "F").Interior.Color _ And Cells(.Item(k), Sp).MergeArea.Interior.ColorIndex xlNone Then Cells(.Item(k), Sp).MergeArea.Interior.Color = Cells(Zeile, "F").Interior.Color Debug.Print "geändert: " & Cells(.Item(k), Sp).MergeArea.Address End If Sum_alt = 0 End If Next k Next Sp End With End Sub

Sub MB12_Version2_Test() Dim LZ As Range Set LZ = ActiveSheet.UsedRange.SpecialCells(11) With CreateObject("scripting.Dictionary") lr = Cells(Rows.Count, "D").End(xlUp).Row 'Mitarbeiter (letzte Zeile) For i = 7 To lr k = Cells(i, "D") If Not .exists(k) Then .Item(k) = i End If Next i For Sp = 13 To LZ.Column Step 5 'ab Spalte M (1. KW) in 5-er Schritten For Each k In .keys ' für jeden Mitarbeiter Anf = .Item(k) + 1 ' Suche ab Spalte MaschNr If IsNumeric(Cells(.Item(k), Sp)) And Cells(.Item(k), Sp) > 0 Then ' Do Sum = WorksheetFunction.Sum(Range(Cells(Anf, Sp), Cells(Anf, Sp).Offset(, 4))) If Sum > Sum_alt Then Sum_alt = Sum Zeile = Anf End If Anf = Anf + 1 'Spalte ProjektNr Loop While Cells(Anf, "D") = k 'solange gleicher Mitarbeiter If Cells(.Item(k), Sp).MergeArea.Interior.Color Cells(Zeile, "F").Interior.Color _ Then Cells(.Item(k), Sp).MergeArea.Interior.Color = Cells(Zeile, "F").Interior.Color Debug.Print "geändert: " & Cells(.Item(k), Sp).MergeArea.Address End If Sum_alt = 0 End If Next k Next Sp End With End Sub

Sub kopieren() Range("F11").Copy Range("R7").PasteSpecial Paste:=xlPasteFormats Range("R7:V7").MergeCells = True Range("R7:V7").Borders(xlEdgeBottom).Color = RGB(0, 0, 0) 'Rahmenlinien erneuern Range("R7:V7").Borders(xlEdgeTop).Color = RGB(0, 0, 0) End Sub

Sub AufrufFarbenZaehlenPrinzip() zeile = 3 Range("H:I").Clear FarbenZaehlen ("M8:Q12") End Sub Sub FarbenZaehlenPrinzip(s$) Dim r As Range, c As Range, Fehler&, k If Len(s) = 0 Then Exit Sub On Error Resume Next Set r = Range(s).SpecialCells(xlCellTypeConstants, 23) Fehler = Err.Number On Error GoTo 0 If Fehler 0 Then Exit Sub With CreateObject("scripting.Dictionary") For Each c In r If IsNumeric(c) Then .Item(c.Interior.Color) = .Item(c.Interior.Color) + c.Value End If Next For Each k In .keys Range("H" & zeile) = k: Range("I" & zeile) = .Item(k) Range("H" & zeile).Interior.Color = k zeile = zeile + 1 Next End With End Sub

Guten Morgen, lieber Michael,
gestern Abend war Margarete nachdenken; bin eher der Frühaufsteher.
Erst mal zu deinem Prinzip: Ob es so oder anders sinnvoller ist, kann ich leider nicht beurteilen. Beim Aufruf habe ich "FarbenZaehlen()" geändert auf "FarbenZaehlenPrinzip()" so war's doch gemeint?
Leider kam beim Durchlauf dann die Fehlermeldung "Laufzeitfehler 1004: Die Methode 'Range' für das Objekt'_Global' ist fehlgeschlagen" nach
For Each k In .keys: bei Range("H" & zeile) = k
Zu deinen Fragen:
In W7:AA7 dürfte keine Farbe drin sein, da der Suchbereich W9:AA12 keine Farbe enthält
Man könnte auch direkt aus dem Suchbereich die Farbe übernehmen, wenn das einfacher ist.

gibt es mehrere Farbwerte in einer Zeile?
Nein, denn die Farbwerte beziehen sich immer auf die RGB-Farbe des Projekts (Spalte F) und der zu bearbeitenden Maschine (Spalte E). Immer eine Aufgabe pro Zeile.

Kann es sein, daß ein und derselbe Farbwert in unterschiedlichen Zeilen vorkommt?
Ja, denn es kann sein, dass Mitarbeiter A über mehrere Wochen eine Maschine konstruiert und zusätzlich Mitarbeiter B dazu bzw. danach detailliert (Detailzeichnungen erstellt).
Warum entspricht die Farbe ab Spalte M nicht immer der Farbe in Spalte F?
Ich vermute, du meinst z.B. rot bei "abwesend" und türkis bei "0". Das sind bedingte Formatierungen.
Wenn in der Zeile direkt unter der Summenzeile in der KW an min. 3 Tagen der KW ein "a" für "abwesend" eingetragen ist, gilt der Mitarbeiter für die gesamte Woche als "abwesend". Die Null erscheint als Hinweis, dass der Mitarbeiter in dieser Woche noch nicht eingeplant wurde, also seine Arbeitszeit noch zur Verfügung steht.
Wie ist der Arbeitsablauf? Die Spalten links von M werden via Makro erzeugt und die anderen Angaben rechts davon kommen händisch rein?
via Makro: nur die Summenzellen ab M und die Farben in Spalten E:F (Button "Farbe")
Alles andere wurde und wird händisch erzeugt. Ausnahmen:
Spalte E - MaschNr per Dropdown aus Blatt "Aufträge",
Spalte F ProjNr mit sverweis() ebenfalls aus Blatt "Aufträge".
Die zugehörigen Farben in Spalten E:F werden über Makro (Button "Farbe") zugewiesen (s.oben).
Das Blatt "Aufträge" wird über Makro (von mir bestmöglich zusammengestrickt) aktualisiert siehe Modul "Auftragsbuch". Dem will ich einen Shortcut zuweisen, da nur unser Team aufs Auftragsbuch zugreifen kann und soll.
Habe jetzt Fenneks Makro in meine ursprüngliche Beispieldatei eingefügt, damit du alle Makros siehst.
Im Modul 3 habe ich testweise die RGB-Farben ausgelesen (siehe Blatt Aufträge).
Meine ursprünglich Idee war z.B.
Mitarbeiter B in KW 32(W:AA):
Summenzeile ist 13, Summenzelle W13
Abwesenheitszeile ist 14(W14:AA14)
Datenbereich Farbe vorhanden ja/nein W15:AA22
Feststellung: wenn in mind. 1 Zelle von W15:AA22 die RGB-Farbe ungleich 255,255,255 ist, dann diese Farbe nach W13 übertragen, Zellen wieder verbinden und Rahmenlinien erneuern.
Das war mein Test:
Range("F11").Copy
Range("R7").PasteSpecial Paste:=xlPasteFormats
Range("R7:V7").MergeCells = True
'Rahmenlinien erneuern
Range("R7:V7").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
Ob das sinnvoll wäre, kann ich nicht beurteilen.
Fennek hatte auf meine Bitte hin auch diesen Fall aufgenommen: Wenn im Bereich W13:AA22 zwei unterschiedliche Farben auftreten, sollte die Farbe übernommen werden, die mit mehr Stunden in der aktuellen KW eingeplant wurden.
Bei Gleichstand in Zeilen 15 und 16 soll die Farbe von Zeile 15 übernommen werden, da die Priorität der Aufgaben von oben nach unten abnimmt.
Das ist aber die Luxus-Ausführung muss oder muss nicht. Wenn das zu aufwendig/störanfällig wäre, würden die Teamleiter angewiesen, pro MA und KW nur eine Aufgabe einzufärben.
Wichtig: Es kommen dauernd Zeilen hinzu oder entfallen, da die Planung sich laufend ändert. Auch Farben kommen hinzu oder entfallen.
Bisherige Farben in den Summenzeilen (außer den bedingten Form.) müssen deshalb natürlich zu Beginn des Makros entfernt werden.
Laienhaft würde ich den Filtermodus aktivieren (Button in D1) und die Farben der sichtbaren Zellen zurücksetzen.
Hinweis: Im Filtermodus (Button in D1) ist die Spalte A sichtbar. Hier ermittle ich über ZÄHLENWENN() die Anzahl der jeweiligen Aufgaben jedes Mitarbeiters. Kann man das nutzen, um die Range zu definieren? Bei Mitarbeiter 2 wäre das z.B.
=ZÄHLENWENN(D:D;D13)-2 Ergebnis = 8
Also Suchbereich ab Zeile 13+2 bis Zeile 13+2+8 (von Zeile 15 bis Zeile 23) und ZEILE()
Bist du noch bei mir? Ich hoffe das beste
Liebe Grüße, Margarete
Hier die Datei:
https://www.herber.de/bbs/user/107731.xlsm

Beliebteste Forumthreads (12 Monate)

VBA Hauptfarben suchen und übertragen

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Hauptfarben suchen und übertragen

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread