Zeilenauswahl wenn Zelle mit vorgegebener Farbe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

…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

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilenauswahl wenn Zelle mit vorgegebener Farbe

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

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread