Zellen färben wenn Gleich wie Markiert.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Martin,
ersetze den Code durch diesen:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Bereich As Range
Dim HLetzte As Long
Dim xZelle As Range
Dim i, j As Long
Dim Farbe As Boolean
If Target.Cells.Count > 1 Then Exit Sub
HLetzte = IIf(IsEmpty(Cells(Rows.Count, 8)), Cells(Rows.Count, 8).End(-4162).Row, Rows.Count)
Set Bereich = ActiveSheet.Range("H2:H" & HLetzte)
If Not Intersect(Target, Bereich) Is Nothing Then
    ActiveSheet.Range("F2:H" & HLetzte).Interior.ColorIndex = 0
    For i = 2 To HLetzte
        For j = 6 To 8
            If Cells(i, j) = Target.Offset(0, j - 8) Then
                Farbe = True
            Else
                Farbe = False
            End If
        Next j
        If Farbe = True Then Range(Cells(i, 6), Cells(i, 8)).Interior.ColorIndex = 6
        Farbe = False
    Next i
End If
End Sub

Bei Mehrfachmarkierung wird die Codeausführung abgebrochen.
Der Code ist natürlich beliebig erweiterbar. Am besten postest Du mal, welche Spalten im Endeffekt betroffen sein sollen.
Gruß aus Leipzig
P@ulchen
www.excel-werkstatt.de

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Bereich1, Bereich2, Bereich3 As Range Dim MLetzte As Long Dim xZelle As Range Dim i, j As Long Dim Farbe As Boolean If Target.Cells.Count > 1 Then Exit Sub MLetzte = IIf(IsEmpty(Cells(Rows.Count, 8)), Cells(Rows.Count, 8).End(-4162).Row, Rows.Count) Set Bereich1 = ActiveSheet.Range("M9:M" & MLetzte) If Not Intersect(Target, Bereich1) Is Nothing Then ActiveSheet.Range("H9:M" & MLetzte).Interior.ColorIndex = 0 For i = 9 To MLetzte For j = 8 To 13 If Cells(i, j) = Target.Offset(0, j - 8) Then Farbe = True Else Farbe = False End If Next j If Farbe = True Then Range(Cells(i, 8), Cells(i, 13)).Interior.ColorIndex = 6 Farbe = False Next i End If End Sub

Hi P@ulchen
Habe die Lösung gefünden, damit nicht falsche Zellen Markiert weden muss eine zusätzliche Prüfung erfolgen, nur wenn j = 8 oder J = 11 oder j = 13 zählt ein Counter mit und bei Counts = 3 und Farbe = true werden die Zellen Markiert.
Jetzt funktioniert es bestens.
Danke für Deine Mithilfe und den Source-Code welcher das für mich ermöglicht hat.
Hier noch der fertige Code:


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Bereich As Range
Dim MLetzte As Long
Dim xZelle As Range
Dim i, j As Long
Dim Farbe As Boolean
Dim Count As Integer
If Target.Cells.Count > 1 Then Exit Sub
MLetzte = IIf(IsEmpty(Cells(Rows.Count, 13)), Cells(Rows.Count, 13).End(-4162).Row, Rows.Count)
Set Bereich = ActiveSheet.Range("M9:M" & MLetzte)
If Not Intersect(Target, Bereich) Is Nothing Then
ActiveSheet.Range("H9:M" & MLetzte).Interior.ColorIndex = 0
For i = 9 To MLetzte
Count = 0
For j = 8 To 13
If Cells(i, j) = Target.Offset(0, j - 13) Then
Farbe = True
If j = 8 Or j = 11 Or j = 13 Then
Count = Count + 1
End If
Else
Farbe = False
End If
Next j
If Farbe = True And Count = 3 Then Range(Cells(i, 8), Cells(i, 13)).Interior.ColorIndex = 6
Farbe = False
Next i
End If
End Sub

Gruss
Martin

Beliebteste Forumthreads (12 Monate)

Zellen färben wenn Gleich wie Markiert.

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread