Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Hauptfarben suchen und übertragen

VBA Hauptfarben suchen und übertragen
14.08.2016 20:55:47
MB12
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

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

Betreff
Datum
Anwender
Anzeige
AW: VBA Hauptfarben suchen und übertragen
15.08.2016 08:16:16
Fennek
Hallo Maggi, (engl. wie "Eiserne Lady")
in einem Nabensatz wird vermutet, dass manchmal der Formatpinsel 2 statt 1 Zeile ändert. Der folgende Code prüft, dass in jeder Zeile nur die Farbe des Profektes (Spalte "F") vorkommt. Im Moment ist das Ändern "aus-kommentiert" und es wird nur die Zeile ins VBA-Direkt-Fenster geschrieben.

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
mfg
PS: die andere Frage könnte machbar sein, auch wenn dort alles (Farben, verbundene Zellen) enthalten ist, von dem die erfahrenen Exilianer nur abraten. Würde aber recht kompliziert werden und du müßtest den Code verstehen, um Fehler korrigieren zu können.
Anzeige
AW: VBA Hauptfarben suchen und übertragen
15.08.2016 09:41:33
Fennek
Hallo,
zuerst: ich habe deine Datei als xlsx (ohne Makros) gespeichert und dann nur meinen Makro eingefügt.
Der folgende Code läuft in der Beispieldatei richtig und Fehlerfrei durch, aber es so viele Varianten, dass der in der Originaldatei vermutlich abbricht. Die Abfrage der "mergedcell" war ziemlich tückig.
Fall die Farbe in der jeweiligen Kopfzeile jedes Mitarbeiters geändert wird, erscheint diese Adresse im Direktfenster.

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
Ich bin froh, dass ich keine Garantie geben muss!!!!!
mfg
https://www.herber.de/bbs/user/107624.xlsm
Anzeige
AW: VBA Hauptfarben suchen und übertragen
15.08.2016 09:57:03
MB12
Hi Fennek, (Wüstenfuchs?),
war gerade dabei, deinen ersten Code durchzuarbeiten.
Bin mal gespannt, was der zweite macht (F8-Freak)
Eins habe ich schon gesehen: Wäre es nicht einfacher, anstatt mit "MergedCells" zu arbeiten
z.B. im Bereich M13:Q13 die Farbe nach M13 zu übertragen? Dann müsste sie doch automatisch im gesamten Bereich sichtbar sein. (Vielleicht zu einfach gedacht).
Ich melde mich, sobald ich deinen Code in etwa verstehe. Habe heute frei fürs Rasenmähen - eher ein Acker - ein groooßer.
Übrigens: In Bezug auf Hartnäckigkeit, wenn ich ein Ziel erreichen möchte/muss, ist "Maggie" nicht ganz abwegig. Hast du vielleicht anhand des Ergebnisses vom Wochenende gesehen.
Liebe Grüße, Margarete
Anzeige
AW: VBA Hauptfarben suchen und übertragen
15.08.2016 10:10:07
MB12
Hi Fennek,
das sieht schon mal sehr gut aus, mein Kompliment.
Allerdings: Bitte sieh dir diese Zellbereiche an:
W7:AA7; AG7:AK7
sowie
AG13:AK13
Hier dürfe keine Farbe drin sein. Ich denke, du findest es schneller als ich.
DANKE
Gruß Margarete
AW: geändert
15.08.2016 15:15:02
Fennek
Hallo,
diese Bedingung hat ich nicht auf dem Plan.
Der Code ist angepasst, nur Zellen, die bereits eine Farbe haben, werden geprüft und im Bedarfsfall überschrieben.

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
Hoffentlich gibt es nicht noch mehr dieser Zusätze.
mfg
Anzeige
AW: geändert - leider Fehler im Code
15.08.2016 16:26:00
MB12
Hallo Fennek,
habe mir überlegt, warum du so ärgerlich warst.
Das war von mir keine Zusatzforderung, sondern der Code verursacht leider diese kleinen Fehler - siehe meine Beschreibung im Post "letzte Hürden".
Deshalb stelle ich nochmal auf "offen".
Trotzdem vielen Dank
Gruß, Margarete
AW:letzte Hürden
15.08.2016 15:22:49
MB12
Hi Fennek (&alle),
soweit es mir möglich war, habe ich jetzt deinen Code getestet.
Der Code geht nacheinander die Spaltenbereiche der KW's durch.
In der ersten KW (M:Q) ist der Farbübertrag aus Zeile 17 korrekt. Weiter unten kommen keine weiteren Ergebnisse – korrekt.
In der zweiten KW (KW 31) (R:V) existiert in den Zeilen 7-12 keine Farbe, der Code übernimmt aber die Farbe aus der vorhergehenden Woche (siehe oben) .
Beim folgenden Durchgang in der gleichen KW ist das Ergebnis wieder korrekt.
Kein weiteres Ergebnis in KW31 – korrekt
Wechsel auf KW 32 – wieder falsch – siehe oben.
Ergebnis: Anscheinend tritt immer beim Wechsel auf die folgende KW der Fehler 1x auf.
Habe die Datei bei diesem Stand "eingefroren":
https://www.herber.de/bbs/user/107632.xlsm
Hier nochmal dein Code (Anmerkungen von mir)
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

Schwierigkeit mit MergedCells wie von dir erwähnt: Ich habe mal rumgespiel (nur mit festen Zellbezügen), und hier funktioniert es, wenn ich die Farbe in die linke Summenzelle übertrage:
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

Übrigens verstehe ich jetzt deine Anmerkung, dass der Code in der Originaldatei wohl nicht durchlaufen wird.
Wenn die Stabilität dadurch erhöht würde, müssten die Kollegen darauf verzichten, einen zweiten Bereich einzufärben, so dass der Vergleich der Summen rausfallen würde ("Do"…bis "End If").
Vielleicht findet auch jemand eine weitere Möglichkeit?
Bei den bisherigen Summenformeln wurde mit Summenprodukt() gearbeitet, aber nach meinem Infostand kann man hierbei in VBA nicht mit Zellbezügen arbeiten- schade.
So kurz vor dem Ziel wäre es schade aufzugeben.
Danke Fennek & alle
Margarete
Anzeige
hat sich überschnitten!!!
15.08.2016 15:28:43
MB12
Hallo Fennek,
sorry, hatte vor dem Hochladen die Liste nicht mehr aktualisiert.
Danke dir sehr herzlich, ich setze mich gleich dran.
Gruß, Margarete
leider noch nicht erledigt
18.08.2016 19:11:01
MB12
Hallo Fennek & Alle,
habe leider in den letzten Tagen keine Antwort mehr erhalten.
Ich fasse den Stand nochmal zusammen:
...."soweit es mir möglich war, habe ich jetzt deinen Code getestet.
Der Code geht nacheinander die Spaltenbereiche der KW's durch.
In der ersten KW (M:Q) ist der Farbübertrag aus Zeile 17 korrekt. Weiter unten kommen keine weiteren Ergebnisse – korrekt.
In der zweiten KW (KW 31) (R:V) existiert in den Zeilen 7-12 keine Farbe, der Code übernimmt aber die Farbe aus der vorhergehenden Woche (siehe oben) .
Beim folgenden Durchgang in der gleichen KW ist das Ergebnis wieder korrekt.
Kein weiteres Ergebnis in KW31 – korrekt
Wechsel auf KW 32 – wieder falsch – siehe oben.
Ergebnis: Anscheinend tritt immer beim Wechsel auf die folgende KW der Fehler 1x auf.
Habe die Datei bei diesem Stand "eingefroren":
https://www.herber.de/bbs/user/107632.xlsm
Hier nochmal dein Code (Anmerkungen von mir)
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

Schwierigkeit mit MergedCells wie von dir erwähnt: Ich habe mal rumgespiel (nur mit festen Zellbezügen), und hier funktioniert es, wenn ich die Farbe in die linke Summenzelle übertrage:
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

Übrigens verstehe ich jetzt deine Anmerkung, dass der Code in der Originaldatei wohl nicht durchlaufen wird.
Wenn die Stabilität dadurch erhöht würde, müssten die Kollegen darauf verzichten, einen zweiten Bereich einzufärben, so dass der Vergleich der Summen rausfallen würde ("Do"…bis "End If").
Vielleicht findet auch jemand eine weitere Möglichkeit?
Bei den bisherigen Summenformeln wurde mit Summenprodukt() gearbeitet, aber nach meinem Infostand kann man hierbei in VBA nicht mit Zellbezügen arbeiten- schade.
So kurz vor dem Ziel wäre es schade aufzugeben.
Danke Fennek & alle
Margarete
PS (18.08.): Sollte euch das Problem nicht wirklich lösbar sein, müsste ich überlegen, was ich in der Datei und dem Ablauf ändern könnte. Ideen wären herzlich willkommen.
Gruß, Margarete
Anzeige
AW: keine Idee
19.08.2016 14:58:06
Fennek
Hallo,
nach einem kurzen Test (nach deinem Kommentar) dachte ich, dass alles ok sei. Seit dem habe ich nicht mehr an dem Thema gearbeitet.
mfg
Ideen hab ich jede Menge
19.08.2016 20:18:07
Michael
Hi Margarete,
die Farbe in W7:AA7 erscheint, weil der Code nicht die Farben der Eintragungen nimmt, sondern die Farbe aus der Spalte F zu der jeweiligen Zeile mit den höchsten Werten.
Das ist für W8:AA12 eben F11 mit hellgrün.
Die Problematik liegt grundsätzlich darin, daß es in VBA keine "schnelle" Möglichkeit gibt, Farbwerte zu verarbeiten, d.h. ohne wirklich JEDESMAL auf das Sheet zuzugreifen.
Oder so: es läßt sich nicht einfach ein ARRAY mit Farbwerten erzeugen (das wäre ne Sache).
Mir stellen sich grundsätzliche Fragen: gibt es mehrere Farbwerte in einer Zeile? Kann es sein, daß ein und derselbe Farbwert in unterschiedlichen Zeilen vorkommt? Warum entspricht die Farbe ab Spalte M nicht immer der Farbe in Spalte F?
Wie ist der Arbeitsablauf? Die Spalten links von M werden via Makro erzeugt und die anderen Angaben rechts davon kommen händisch rein?
Wenn das so sein sollte, könnte man mit einem Change-Event eine "Spiegel-Tabelle" mit den interior.color-Werten bestücken (während der Eingabe, das ist zeitlich völlig unkritisch), die dann als Array eingelesen und verwurschtelt wird - das rennt. Man müßte die halt zuvor "einmal" mit den bereits vorhandenen Eingaben erzeugen.
Naja, ist vielleicht mit Kanonenkugeln auf Spatzen geschossen.
Eine Frage noch: bei gleichen Werten (also 5x4 und 5x4): "von oben holen"? Bitte exakte Angabe mit Adresse.
Muß zum Abwasch.
Schöne Grüße erst Mal,
Michael
Anzeige
AW: Ideen hab ich jede Menge
19.08.2016 21:06:20
MB12
Hallo Michael,
danke viiielmals, dass du dich damit beschäftigst. Werde gleich morgen früh deine Fragen durcharbeiten und beantworten und dir auch schreiben, welche Ideen ich inzwischen hatte.
Manchmal muss man einen neuen Blickwinkel einnehmen.
Bis morgen denn
Grüßle, Margarete
na dann
19.08.2016 22:33:32
Michael
Hi Margarete,
freut mich, wenn's Dich freut...
Hm, ich hatte aber schon wieder einen Denkfehler: die Eingaben werfen ein Event, das Färben der Zellen aber nicht: kannste also vergessen.
Hier mal ne Prinzip-Sache: das Zählen der Farben/Werte wird "gekapselt":
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

Kopiere das mal in eine leere Tabelle, mal ein bißchen was rein in M8:Q12 und laß das obere Makro laufen.
Ich stelle mir das so vor, daß "außerhalb" die Abfrage auf "abwesend" bzw. 0 erfolgt, und wenn der Bereich denn ausgewertet werden muß, übergibt man einfach die Adresse. Wobei: in der Praxis ist es sicher einfacher, einen Range zu übergeben, dann muß man den String nicht zusammensetzen.
Ich mag heute nimmer.
Grüße,
Michael
Anzeige
AW: na dann
20.08.2016 09:28:54
MB12
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
Anzeige
AW: na dann
20.08.2016 15:33:22
Michael
Hi Margarete,
ich weiß nicht, ob ich noch "bei Dir bin": die Geschichte ist a) ziemlich komplex und b) habe ich das Gefühl, wir reden aneinander vorbei.
Zu allem Überfluß stecke ich gedanklich gerade in einer anderen Geschichte, die ich übers Wochenende erledigt haben möchte (bevor sie anfängt, zu nerven, weil's zu lange dauert).
Deshalb würde ich vorschlagen, Du schickst mir ne mail mit Deiner Tel., dann sprechen wir z.B. am MO oder DI nachmittag (so ab 15h).
Ich sehe die Geschichte gedanklich in "Kästchen" pro MA bzw. Woche, im Prinzip ohne die 1. Zeile mit der Summe, also die reinen Werte. Daß Farben in unterschiedlichen "Kästchen" mehrfach vorkommen können, ist klar: es ging mir um ein und dasselbe Kästchen.
Sind die Farben in E und F immer identisch? Und nochmal: warum sind hier die 7er NICHT in der Farbe von Spalte E?
Userbild
Hier siehst Du schön, daß Fenneks Makro wunderbar funktioniert, wenn die zu übernehmende Farbe die aus Spalte E/F ist...
Schöne Grüße,
Michael
gar kein Problem,...
20.08.2016 16:27:16
MB12
Michael, ich habe schon gedacht, dass die Lösung nicht so schnell geht, Präsentation soll erst am Do. erfolgen. Und der Job geht vor.
Mail an dich geht gleich raus.
Deine Fragen/Anmerkungen:
Fenneks Code ist fast perfekt, aber siehe meine Anmerkungen vom 15.08.:
"Der Code geht nacheinander die Spaltenbereiche der KW's durch.
In der ersten KW (M:Q) ist der Farbübertrag aus Zeile 17 korrekt. Weiter unten kommen keine weiteren Ergebnisse – korrekt.
In der zweiten KW (KW 31) (R:V) existiert in den Zeilen 7-12 keine Farbe, der Code übernimmt aber die Farbe aus der vorhergehenden Woche (siehe oben) .
Beim folgenden Durchgang in der gleichen KW ist das Ergebnis wieder korrekt.
Kein weiteres Ergebnis in KW31 – korrekt
Wechsel auf KW 32 – wieder falsch – siehe oben.
Ergebnis: Anscheinend tritt immer beim Wechsel auf die folgende KW der Fehler 1x auf."

Farben in E und F sind immer identisch. Ich musste für mein Makro die Farbe aus Register "Aufträge" in die Spalte F übernehmen, Spalte E funzt nicht, da Dropdown. Aber hier ist es völlig Wurscht, welche Spalte man nimmt.
Keine Farbe bei den 7-ern in Zeile 19: kann durchaus sein, wenn der Teamleiter nicht per Formatpinsel die Zahlen eingefärbt hat. Der muss das immer selbst entscheiden, was am dringendsten ist. Dann muss auch die "40" in Summenzeile 13 farblos bleiben.
Ob es dabei bleiben muss, kann ich gleich morgen früh abklären, so dass wir am Nachmittag (Mo oder Di wie vorgeschlagen) darüber sprechen können.
Liebe Grüße, Margarete
AW: gar kein Problem,...
20.08.2016 19:57:49
Michael
Hi Margarete,
genau das ist der Punkt: kann durchaus sein, wenn der Teamleiter nicht per Formatpinsel die Zahlen eingefärbt hat. Der muss das immer selbst entscheiden, was am dringendsten ist. Dann muss auch die "40" in Summenzeile 13 farblos bleiben.

Dann soll der Teamleiter die Eingaben halt in der Zeile machen, wo die entsprechende Farbe ist!
Ich hätte Dir ja schon gestern Abend "schnell eine Lösung kodiert" (ich wollte, wie Du Dir denken kannst, hingerotzt vermeiden, hehe), aber es ist EINE Sache, die Zeile mit den höchsten Werten zu ermitteln und die Farbe aus E/F zu übernehmen und eine ganz ANDERE, aus besagter ZEILE dann auch noch die Farbe EINZELNER ZELLEN auszulesen: die Summe der kompletten Zeile wird ja mit dem =worksheetfunction.Sum(...) ermittelt; alternativ müßte man dann wirklich jede einzelne Zelle händisch aufaddieren - Du kannst Dir vorstellen, daß DIESER Ansatz bei sehr vielen Daten dauert!
Ich sag's Dir: ein G'frett!
Meine mails seh ich heute nimmer an, ich muß jetzt arbeiten...
Schöne Grüße,
Michael
könnte ein Missverständnis sein
20.08.2016 20:33:32
MB12
Hi Michael,
deine Nachricht könnte auf einem Mißverständnis basieren.
In jeder Zeile kann nur diejenige Farbe auftauchen, die in E/F enthalten ist - ohne Ausnahme. Die Alternative ist nur, dass z.B. von der Vorwoche bei einer anderen Aufgabe noch dringende Restarbeiten mit wenigen Stunden zu erledigen sind, was Prio 1 hat. Deshalb soll der Verantwortliche die wichtigste Aufgabe mit der Farbe aus E/F - aus der gleichen Zeile - highlighten. Ich hoffe, so kann man das "G'frett" vermeiden.
So besser verständlich? Sonst kann ich es dir per Skype demonstrieren. Und was net geht, des geht halt net - Punkt. Ich werde weder dich noch mich selbst ärgern.
Gruß, und bis zum "Date", bin auf HabAcht
Margarete

325 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige