Zeilenauswahl wenn Zelle mit vorgegebener Farbe

Forumthread: Zeilenauswahl wenn Zelle mit vorgegebener Farbe

31.01.2015 17:46:22

obelix-xxl

Hallo,
ich bitte um Unterstützung bei folgender Aufgabe.
Gegeben sind in der ersten Zeile mehrere Zellinhalte (Text), die farbig hinterlegt sind. Diese Farben signalisieren eine Terminbewertung eines Zustands.
So ist z.B. B1 grün hinterlegt (Text = erledigt). D1 ist blau hinterlegt (Text = in Bearbeitung), usw....
In der darunter aufgebauten Tabelle sind Einträge als Datum oder Texthinweise mit den in Zeile 1 hinterlegte Farben markiert.
Zur Problemdarstellung:
Die in Zeile 1 hinterlegten Farben sollen erkannt werden und die Zeilen mit diesen vorgegebenen Farben sollen automatisch auf dem Bildschirm verbleiben, also selektiert werden. Die Zeilen in denen sich keine ausgewählte farbige Zelle befindet sollen ausgeblendet sein.
Also wenn ich z. B. Auf D1 klicke möchte ich alle kompletten Zeilen, in denen eine blau gefärbte Zelle ist, untereinander auf dem Bildschirm sehen können. Klicke ich danach auf die Zelle B1 so sollen alle Zeilen in denen sich gelbe Zellen befinden auf dem Bildschirm verbleiben.
Wie erreiche ich einen RESET der Auswahl um die Tabelle nach der Bearbeitung wieder komplett sehen zu können?
Hier die Beispieldatei: https://www.herber.de/bbs/user/95447.xlsx
LG
obelix

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Das ist alles kein sonderliches Problem, wenn ...

31.01.2015 19:45:53

Luc:-?

…du eine EreignisProzedur benutzt, Obelix,
denn du willst ja zur Auswahl auf die FarbZellen in der 1.Zeile klicken. Das wäre dann das SelectionChange-Ereignis des betreffenden Blattes. Normalerweise macht man so etwas ja per FilterMethode (geht auch für ZellFarben), aber eben spaltenweise. Für ganze Zeilen mache Folgendes:
1. Öffne den VBEditor und (doppel-)klicke im linken oberen Fenster auf Tabelle1 in der BaumStruktur!
2. Das rechte große Fenster zeigt dann oben 2 Dropdown-Felder. Wähle im linken Worksheet! Es wird sofort der ProzedurRahmen für das StandardEreignis des Blattes angelegt → SelectionChange.
3. Ersetze die LeerZeile zwischen ProzedurKopf und -Fuß durch folgd PgmCode:

    Const adAwFrb$ = "A1:T1", adRelGesBer$ = "B4:K54", _
hxRelAwFrb$ = "&h66FF66 &hFFCC00 &h33FF &hFFFF &hFF00FF &h99FF"
Dim ix As Long, selAwFrb As Long, axRelAwFrb$(), avRelAwFrb, _
calc As XlCalculation, xZ As Range, xZl As Range
On Error Resume Next
If Not Intersect(Target, Me.Range(adAwFrb)) Is Nothing Then
If Target.MergeCells Or Target.Count = 1 Then
With Application
calc = .Calculation: .Calculation = xlCalculationManual
.ScreenUpdating = False
End With
axRelAwFrb = Split(hxRelAwFrb): ReDim avRelAwFrb(UBound(axRelAwFrb))
For ix = 0 To UBound(axRelAwFrb)
avRelAwFrb(ix) = CLng(axRelAwFrb(ix))
Next ix
ix = 0: ix = WorksheetFunction.Match(Target(1).Interior.Color, avRelAwFrb, 0)
Me.Range(adRelGesBer).Rows.Hidden = False
If CBool(ix) Then
For Each xZl In Me.Range(adRelGesBer).Rows
For Each xZ In xZl.Cells
If xZ.Interior.Color = avRelAwFrb(ix - 1) Then Exit For
Next xZ
If xZ Is Nothing Then
xZl.EntireRow.Hidden = True
Else: Set xZ = Nothing
End If
Next xZl
End If
With Application
.Calculation = calc: .ScreenUpdating = True
End With
End If
End If

Sollte sich künftig etwas ändern (mehr Farben, zusätzliche Spalten/Zeilen o.Ä.), müssen idR nur die Konstanten am PgmAnfang geändert wdn.
Bei jedem Klick in den relevanten Bereich der 1.Zeile (A1:T1) wdn alle Zeilen des GesamtBereichs eingeblendet und anschld, falls auf einen der 6 farbigen Bereiche geklickt wurde, alle Zeilen des GesamtBereichs ausgeblendet, in denen keine ihrer Zellen die angeklickte Farbe aufweist. Das muss dann auch genau diese Farbe sein!
Viel Spaß + schöSo! Gruß, Luc :-?

AW: Das ist alles kein sonderliches Problem, wenn ...

01.02.2015 10:29:43

obelix-xxl

Hallo Luc,
super wie das sofort funktioniert. Damit hätte ich nicht gerechnet. Danke für Deinen Einsatz. Das spart mir etwas Arbeit UND ich habe wieder ein klein wenig dazu gelernt. Den Bereich kann ich zuordnen und auch soweit anpassen. Auch sind Deine erklärenden Worte sehr hilfreich, das ist eine perfekt beschriebene Arbeitsanweisung.
Wenn es nicht zuviel Mühe macht prüfe bitte einmal nachfolgende Ergänzung. In der nachfolgenden Befehlszeile hast Du die Farben festgelegt:
hxRelAwFrb$ = "&h66FF66 &hFFCC00 &h33FF &hFFFF &hFF00FF &h99FF"
Besteht die Möglichkeit die in Zeile 1 enthaltenen Farben in diese Befehlszeile auszulesen? So könnte man die Tabelle noch etwas durch andere Farben oder erweiterte Farben variieren.
Ich komme so aber super zurecht. Nochmals DANKE.
Spaß habe ich jetzt und einen schönen Sonntag auch!
LG
obelix

Ja, daran hätte ich auch gleich denken können, ...

01.02.2015 14:28:00

Luc:-?

…Obelix;
ändere also den 1.Teil der Prozedur wie folgt:

    Const adAwFrb$ = "A1:T1", adRelGesBer$ = "B4:K54", _
irRelFbZn As Long = 2   'Anm: 0=keine 1=nur 1. 2=1.+ltz Zelle irrelevant
Dim ix As Long, FbAnz As Long, calc As XlCalculation, avRelAwFrb As Variant, _
xZ As Range, xZl As Range
On Error Resume Next
If Not Intersect(Target, Me.Range(adAwFrb)) Is Nothing Then
If Target.MergeCells Or Target.Count = 1 Then
With Application
calc = .Calculation: .Calculation = xlCalculationManual
.ScreenUpdating = False
End With
FbAnz = Me.Range(adAwFrb).Cells.Count - irRelFbZn: ReDim avRelAwFrb(FbAnz - 1)
For Each xZ In Me.Range(adAwFrb).Cells(1 - CInt(CBool(irRelFbZn))).Resize(1, FbAnz)
avRelAwFrb(ix) = xZ.Interior.Color: ix = ix + 1
Next xZ

Ab Zeile ix = 0: ix = WorksheetFunction.Match … bleibt alles wie bisher.
Übrigens hast du (in Zeilen 29/34 2 ZellFarben zum Signieren verwendet, die nicht in Zeile 1 aufgeführt sind.
Gruß, Luc :-?

AW: Ja, daran hätte ich auch gleich denken können, ...

01.02.2015 15:13:11

obelix-xxl

Hallo Luc,
die Ergänzung / Änderung habe ich eingetragen. Jedoch funktioniert das Modul dann nicht mehr.
Hier der komplette Code:
Const adAwFrb$ = "A1:T1", adRelGesBer$ = "B4:K54", _
irRelFbZn As Long = 2 'Anm: 0=keine 1=nur 1. 2=1.+ltz Zelle irrelevant
Dim ix As Long, FbAnz As Long, calc As XlCalculation, avRelAwFrb As Variant, _
xZ As Range, xZl As Range
On Error Resume Next
If Not Intersect(Target, Me.Range(adAwFrb)) Is Nothing Then
If Target.MergeCells Or Target.Count = 1 Then
With Application
calc = .Calculation: .Calculation = xlCalculationManual
.ScreenUpdating = False
End With
FbAnz = Me.Range(adAwFrb).Cells.Count - irRelFbZn: ReDim avRelAwFrb(FbAnz - 1)
For Each xZ In Me.Range(adAwFrb).Cells(1 - CInt(CBool(irRelFbZn))).Resize(1, FbAnz)
avRelAwFrb(ix) = xZ.Interior.Color: ix = ix + 1
Next xZ
ix = 0: ix = WorksheetFunction.Match(Target(1).Interior.Color, avRelAwFrb, 0)
Me.Range(adRelGesBer).Rows.Hidden = False
If CBool(ix) Then
For Each xZl In Me.Range(adRelGesBer).Rows
For Each xZ In xZl.Cells
If xZ.Interior.Color = avRelAwFrb(ix - 1) Then Exit For
Next xZ
If xZ Is Nothing Then
xZl.EntireRow.Hidden = True
Else: Set xZ = Nothing
End If
Next xZl
End If
With Application
.Calculation = calc: .ScreenUpdating = True
End With
End If
End If
End Sub
Ich finde nicht die Ursache. Werden die Routinen nicht richtig beendet? Auch der Debugger meckert nicht. ?
Die Farbunterschiede sind jetzt auch beseitigt. Danke für den Hinweis.
LG obelix

Die KopfZeile hast du hoffentlich stehen ...

01.02.2015 17:53:07

Luc:-?

…lassen und nicht mit entfernt, Obelix,
denn das hatte ich stillschweigend vorausgesetzt → ohne KopfZeile nämlich auch keine Prozedur. Allerdings hätte sich dann der Debugger melden müssen…
Das schreibe ich nur, weil ich das getestet hatte und du „der komplette Code“ schreibst, obwohl die KopfZeile fehlt. Allerdings könnte da noch eine Unschönheit drin sein, auf die Xl12/2007 aber nicht negativ reagiert hat. Sehe ich mir noch mal an (dann reicht's aber!).
Luc :-?

AW: Die KopfZeile hast du hoffentlich stehen ...

01.02.2015 18:09:16

obelix-xxl

Hallo Luc,
ich habe einen Fehler gemacht und in der ersten Zeile etwas überschrieben.
Den kompletten Code habe ich wieder am Laufen.
Entschuldige bitte, die zusätzliche Mühe.
Nochmals meinen größten Dank an Dich.
Farbwechsel ist jetzt problemlos in der ersten Zeile möglich. Super.
LG
obelix

Na ja, macht nix! Nur der Vollständigkeit ...

02.02.2015 00:34:06

Luc:-?

…halber, Obelix,
die (kleine) Unschönheit besteht darin, dass die Farben aller Zellen aufgezeichnet wdn, obwohl etliche verbunden sind, was dazu führt, dass deren Farben mehrfach aufgeführt wdn (allerdings findet/verwendet .Match stets nur die 1. der mehrfach enthaltenen). Außerdem sind noch 2 farblose schmale Zellen (der Teilungsspalten), deren Farbe als weiß interpretiert wird, enthalten. Da aber im relevanten GesamtBereich jede Zeile weiße (keine farblosen) Zellen enthält, wird bei dem etwas schwierigen, aber dennoch möglichen Klick auf diese Zellen auch nichts ausgeblendet. Wollte man das dennoch ausschließen, könnte man auch noch danach fragen. Quasi als LehrBsp habe ich das alles mal im nachfolgd GesamtPgm berücksichtigt (die ZellFarbe Weiß könnte damit auch im Kopf verwendet wdn, was hier aber sinnlos ist, weil ohnehin keine Zeile im relevanten GesamtBereich gänzlich ungefärbt ist):

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const adAwFrb$ = "A1:T1", adRelGesBer$ = "B4:K54", _
irRelFbZn As Long = 2   'Anm: 0=keine 1=nur 1. 2=1.+ltz Zelle irrelevant
Dim isMgArea As Boolean, cx As Long, ix As Long, mx As Long, FbAnz As Long, _
calc As XlCalculation, avRelAwFrb As Variant, xZ As Range, xZl As Range
On Error Resume Next
If Not Intersect(Target, Me.Range(adAwFrb)) Is Nothing Then
If Target.MergeCells Or Target.Count = 1 Then
With Application
calc = .Calculation: .Calculation = xlCalculationManual
.ScreenUpdating = False
End With
FbAnz = Me.Range(adAwFrb).Cells.Count - irRelFbZn: ReDim avRelAwFrb(FbAnz - 1)
For Each xZ In Me.Range(adAwFrb).Cells(1 - CInt(CBool(irRelFbZn))).Resize(1, FbAnz)
If cx = mx Then
If xZ.Interior.ColorIndex > 0 Then _
avRelAwFrb(ix) = xZ.Interior.Color: ix = ix + 1
If xZ.MergeCells Then mx = mx + xZ.MergeArea.Cells.Count Else mx = mx + 1
End If
cx = cx + 1
Next xZ
FbAnz = ix: ix = 0: ReDim Preserve avRelAwFrb(FbAnz - 1)
ix = WorksheetFunction.Match(Target(1).Interior.Color, avRelAwFrb, 0)
Me.Range(adRelGesBer).Rows.Hidden = False
If CBool(ix) Then
For Each xZl In Me.Range(adRelGesBer).Rows
For Each xZ In xZl.Cells
If xZ.Interior.ColorIndex > 0 And _
xZ.Interior.Color = avRelAwFrb(ix - 1) Then Exit For
Next xZ
If xZ Is Nothing Then xZl.EntireRow.Hidden = True Else Set xZ = Nothing
Next xZl
End If
With Application: .Calculation = calc: .ScreenUpdating = True: End With
End If
End If
End Sub

Luc :-?

Beliebteste Forumthreads (12 Monate)

Zeilenauswahl wenn Zelle mit vorgegebener Farbe

Forumthread: Zeilenauswahl wenn Zelle mit vorgegebener Farbe

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Zeilenauswahl wenn Zelle mit vorgegebener Farbe

Forumthread: Zeilenauswahl wenn Zelle mit vorgegebener Farbe

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread