Bedingte Formatierung

Hallo
ich sitze jetzt seit einiger Zeit vor der Tabelle:
über das Worksheet_SelectionChange ausgelöst möchte ich, wenn ich in Spalte D eine Zelle auswähle
alle Zellen grün färben (von Spalte A bis L), die in Spalte D den gleichen Wert haben.
Ich bekomm es einfach nicht hin.
Das hier färbt nur die Werte in D....
Wer kann mir helfen. Ggf. ist mein Ansatz ja auch kompl. falsch?
Excel 2007

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("D:D")) Is Nothing Then
        Dim Z&, LR&
        LR = Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
        If Target.Row <= LR Then
            Z = Target.Row 'aktuelle Zeile
            With Range("D2:D" & LR)
                Cells.FormatConditions.Delete
                .FormatConditions.Add Type:=xlExpression, Formula1:="=D" & Z & "=$D$" & Z
                .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1).Interior 'grüner Hintegrund
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.399945066682943
                End With
            End With
        End If
    End If
End Sub

Danke
Gruß UweD

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit 'https://www.herber.de/ _ forum/archiv/1052to1056/t1052497.htm Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Z&, LR& If Not Intersect(Target, Range("D:D")) Is Nothing Then LR = Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte If Target.Row And Target.Row > 1 Then Z = Target.Row 'aktuelle Zeile With Range("A2:L" & LR) Cells.FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=D" & Z & "=$D$" & Z .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With .FormatConditions(1).Interior 'grüner Hintegrund .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent3 .TintAndShade = 0.399945066682943 End With End With End If End If End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Bereich As Range, rZelle As Range Dim Anzahl As Long With Application .ScreenUpdating = False .EnableEvents = False 'Farben zurücksetzen Range("A:L").Interior.ColorIndex = xlNone If Not Intersect(Target, Columns(4)) Is Nothing Then 'Bereich Set Bereich = Range("D1", Cells(Rows.Count, 4).End(xlUp)) 'Anzahl Zellen Anzahl = Application.WorksheetFunction.CountIf(Bereich, Target) 'Schleife über die Zellen For Anzahl = 1 To Anzahl If Anzahl = 1 Then Set rZelle = Bereich.Find(Target, , xlValues, 2, 1, xlNext, False, False, False) Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 12)).Interior.ColorIndex = 4 Else Set rZelle = Bereich.FindNext(rZelle) Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 12)).Interior.ColorIndex = 4 End If Next Anzahl End If .ScreenUpdating = True .EnableEvents = True End With End Sub

Hallo,
besser geht es hiermit, wenn Du mehrere Zellen auf einmal auswählst.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Bereich As Range, rZelle As Range, meTarget As Range
Dim Anzahl As Long

With Application
 .ScreenUpdating = False
 .EnableEvents = False
    'Farben zurücksetzen 
    Range("A:L").Interior.ColorIndex = xlNone
       For Each meTarget In Target
         If Not Intersect(meTarget, Columns(4)) Is Nothing And meTarget <> "" Then
            'Bereich 
            Set Bereich = Range("D1", Cells(Rows.Count, 4).End(xlUp))
            'Anzahl Zellen 
            Anzahl = Application.WorksheetFunction.CountIf(Bereich, meTarget)
            'Schleife über die Zellen 
            For Anzahl = 1 To Anzahl
             If Anzahl = 1 Then
              Set rZelle = Bereich.Find(meTarget, , xlValues, 2, 1, xlNext, False, False, False)
              Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 12)).Interior.ColorIndex = 4
             Else
              Set rZelle = Bereich.FindNext(rZelle)
              Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 12)).Interior.ColorIndex = 4
             End If
            Next Anzahl
         End If
        Next meTarget
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread