Bedingte Formatierung in Liste übertragen

Ich habe eine Pendenzenliste mit bedingten Formatierungen über VBA (siehe Mustervorlage). Dabei werden die Farben der Kürzel aus der Legende auf die Kürzel in der Liste automatisch übertragen. Dieser Vorgang funktioniert soweit ganz gut.
Nun will ich den Code für die bedingte Formatierung wie folgt erweitern:
Sobald in der Legende eine Farbe eines Kürzels geändert wird, müssen alle selben Kürzel in der Liste (in einem Vorgang) mit der neu zugeteilten Farbe aktualisiert werden. Da die Liste immer wie länger wird, ist es mühsam bei einer Farbänderung alle Kürzel manuell anpassen zu müssen.
Bis jetzt habe ich schon einiges ausprobiert, leider ohne Erfolg. Ich hoffe, jemand von euch kann mir dabei weiterhelfen.
Gruss
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub FarbenAnpassen() Dim lngStart As Long Dim lngZeile As Long Dim rngZelle As Range Dim strStart As String Dim lngEnde As Long lngStart = Columns(1).Find("Legende:", lookat:=xlWhole).Row + 1 lngEnde = Cells(lngStart, 1).End(xlUp).Row For lngZeile = lngStart To IIf(IsEmpty(Cells(Rows.Count, 6)), Cells(Rows.Count, 6).End(xlUp). _ Row, Rows.Count) Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).Find(Cells(lngZeile, 6), lookat:= _ xlWhole) If Not rngZelle Is Nothing Then strStart = rngZelle.Address Do rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).FindNext(rngZelle) Loop While Not rngZelle Is Nothing And rngZelle.Address strStart End If Next lngZeile End Sub

Sub FarbenAnpassen() Dim rngZelle As Range Dim lngStart As Long Dim lngZeile As Long Dim strStart As String Dim lngEnde As Long lngEnde = Cells(5, 1).End(xlDown).Row lngStart = Cells(lngEnde, 1).End(xlDown).Row + 1 For lngZeile = lngStart To IIf(IsEmpty(Cells(Rows.Count, 6)), _ Cells(Rows.Count, 6).End(xlUp).Row, Rows.Count) Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).Find(Cells(lngZeile, 6), _ lookat:=xlWhole) If Not rngZelle Is Nothing Then strStart = rngZelle.Address Do rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).FindNext(rngZelle) Loop While Not rngZelle Is Nothing And rngZelle.Address strStart End If Next lngZeile End Sub

Sub FarbenAnpassen() Dim rngZelle As Range Dim lngStart As Long Dim lngZeile As Long Dim strStart As String Dim lngEnde As Long lngEnde = Cells(5, 1).End(xlDown).Row lngStart = Cells(lngEnde, 1).End(xlDown).Row + 1 For lngZeile = lngStart To IIf(IsEmpty(Cells(Rows.Count, 6)), _ Cells(Rows.Count, 6).End(xlUp).Row, Rows.Count) Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).Find(Cells(lngZeile, 6), _ lookat:=xlWhole) If Not rngZelle Is Nothing Then strStart = rngZelle.Address If Cells(rngZelle.Row, 10) = "e" Then _ rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Do rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).FindNext(rngZelle) Loop While Not rngZelle Is Nothing And rngZelle.Address strStart End If Next lngZeile End Sub

Sub FarbenAnpassen() Dim rngZelle As Range Dim lngStart As Long Dim lngZeile As Long Dim strStart As String Dim lngEnde As Long lngEnde = Cells(5, 1).End(xlDown).Row lngStart = Cells(lngEnde, 1).End(xlDown).Row + 1 For lngZeile = lngStart To IIf(IsEmpty(Cells(Rows.Count, 6)), _ Cells(Rows.Count, 6).End(xlUp).Row, Rows.Count) Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).Find(Cells(lngZeile, 6), _ lookat:=xlWhole) If Not rngZelle Is Nothing Then strStart = rngZelle.Address Do If Cells(rngZelle.Row, 10) = "e" Then _ rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).FindNext(rngZelle) Loop While Not rngZelle Is Nothing And rngZelle.Address strStart End If Next lngZeile End Sub

Hallo Beverly
Vielen Dank. Jetz funktioniert der Code einwandfrei. Ich musste nur noch = "e" durch "e" ersetzen.
Ich habe noch ein kleines Problem. In der selben Liste will ich mit einem Modul den Text in allen Zeilen (Spalte A bis K) in Abhängigkeit von Werte in Spalte A und J einfärben und die entsprechende Schriftdicke setzen:
Wenn Wert in Spalte A: Letzte 2 Ziffern = "00" und Wert in Spalte J: "p", dann
- Schrift von Spalte A bis K = schwarz (1), dick
Wenn Wert in Spalte A: Letzte 2 Ziffern = "00" und Wert in Spalte J: "e", dann
- Schrift von Spalte A bis K = grau (16), dick
Wenn Wert in Spalte A: Letzte 2 Ziffern "00" und Wert in Spalte J: "p", dann
- Schrift von Spalte A bis K = schwarz (1), dünn
Wenn Wert in Spalte A: Letzte 2 Ziffern "00" und Wert in Spalte J: "e", dann
- Schrift von Spalte A bis K = grau (16), dünn
Um dies umzusetzen, habe ich folgenden Code erstellt:

Sub Formatieren_ep()
Dim ZelleU As Long
Dim rngRow As Range
Dim Zeile As Long
With ActiveSheet
ZelleU = .Cells(.Rows.Count, 1).End(xlUp).Row - 8
rngRow = .Range(.Rows(.Cells(1, 5)), .Rows(ZelleU, 11))
Zeile = rngRow.Row
With rngRow
If Right(.Cells(Zeile, 1), 2) = "00" And .Cells(Zeile, 7) = "p" Then
.ColorIndex = 1:
.Bold = True
ElseIf Right(.Cells(Zeile, 1), 2) = "00" And .Cells(Zeile, 7) = "e" Then
.ColorIndex = 16:
.Bold = True
ElseIf Right(.Cells(Zeile, 1), 2)  "00" And .Cells(Zeile, 7) = "p" Then
.ColorIndex = 1:
.Bold = False
ElseIf Right(.Cells(Zeile, 1), 2)  "00" And .Cells(Zeile, 7) = "e" Then
.ColorIndex = 16:
.Bold = False
End If
End With
Next
End With
End Sub

Leider habe ich diesen Code noch nicht zum Laufen gebracht. Ich weiss nicht, was ich falsch mache.
Anscheinend liege ich mit meinem Ansatz wieder einmal total daneben. Ich hoffe, es kann mir jemand helfen. Das ganze muss in ein Modul gepackt werden.
Gruss
Stefan

Sub Formatieren_ep() Dim ZelleU As Long Dim Zeile As Long Dim rngRow As Range ZelleU = Cells(Rows.Count, 1).End(xlUp).Row - 8 For Zeile = 5 To ZelleU Set rngRow = Range(Cells(Zeile, 1), Cells(Zeile, 11)) With rngRow If Right(.Cells(1), 2) = "00" And .Cells(10) = "p" Then .Font.ColorIndex = 1 .Font.Bold = True ElseIf Right(.Cells(1), 2) = "00" And .Cells(10) = "e" Then .Font.ColorIndex = 16 .Font.Bold = True ElseIf Right(.Cells(1), 2) "00" And .Cells(10) = "p" Then .Font.ColorIndex = 1 .Font.Bold = False ElseIf Right(.Cells(1), 2) "00" And .Cells(10) = "e" Then .Font.ColorIndex = 16 .Font.Bold = False End If End With Next Set rngRow = Nothing End Sub

Sub Formatieren_ep() Dim ZelleU As Long Dim Zeile As Long Dim rngRow As Range ZelleU = Cells(Rows.Count, 1).End(xlUp).Row - 8 For Zeile = 5 To ZelleU Set rngRow = Union(Range(Cells(Zeile, 1), Cells(Zeile, 5)), Range(Cells(Zeile, 7), Cells( _ Zeile, 11))) With rngRow If Right(.Cells(1), 2) = "00" And .Cells(10) = "p" Then .Font.ColorIndex = 1 .Font.Bold = True ElseIf Right(.Cells(1), 2) = "00" And .Cells(10) = "e" Then .Font.ColorIndex = 16 .Font.Bold = True ElseIf Right(.Cells(1), 2) "00" And .Cells(10) = "p" Then .Font.ColorIndex = 1 .Font.Bold = False ElseIf Right(.Cells(1), 2) "00" And .Cells(10) = "e" Then .Font.ColorIndex = 16 .Font.Bold = False End If End With Next Set rngRow = Nothing End Sub

Sub Formatieren_ep() Dim ZelleU As Long Dim Zeile As Long Dim rngRow As Range ZelleU = Cells(Rows.Count, 1).End(xlUp).Row - 8 For Zeile = 5 To ZelleU Set rngRow = Union(Range(Cells(Zeile, 1), Cells(Zeile, 5)), _ Range(Cells(Zeile, 7), Cells(Zeile, 11))) If Right(Cells(Zeile, 1), 2) = "00" And Cells(Zeile, 10) = "p" Then rngRow.Font.ColorIndex = 1 rngRow.Font.Bold = True ElseIf Right(Cells(Zeile, 1), 2) = "00" And Cells(Zeile, 10) = "e" Then rngRow.Font.ColorIndex = 16 rngRow.Font.Bold = True ElseIf Right(Cells(Zeile, 1), 2) "00" And Cells(Zeile, 10) = "p" Then rngRow.Font.ColorIndex = 1 rngRow.Font.Bold = False ElseIf Right(Cells(Zeile, 1), 2) "00" And Cells(Zeile, 10) = "e" Then rngRow.Font.ColorIndex = 16 rngRow.Font.Bold = False End If Next Set rngRow = Nothing End Sub

Sub FarbenAnpassen() Dim rngZelle As Range Dim lngStart As Long Dim lngZeile As Long Dim strStart As String Dim lngEnde As Long lngEnde = Cells(5, 1).End(xlDown).Row lngStart = Cells(lngEnde, 1).End(xlDown).Row + 1 For lngZeile = lngStart To IIf(IsEmpty(Cells(Rows.Count, 6)), _ Cells(Rows.Count, 6).End(xlUp).Row, Rows.Count) Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).Find(Cells(lngZeile, 6), _ lookat:=xlWhole) If Not rngZelle Is Nothing Then strStart = rngZelle.Address If Cells(rngZelle.Row, 10) = "e" Then _ rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Do rngZelle.Font.ColorIndex = Cells(lngZeile, 6).Font.ColorIndex Set rngZelle = Range(Cells(5, 6), Cells(lngEnde, 6)).FindNext(rngZelle) Loop While Not rngZelle Is Nothing And rngZelle.Address strStart End If Next lngZeile End Sub

Beliebteste Forumthreads (12 Monate)

Bedingte Formatierung in Liste übertragen

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bedingte Formatierung in Liste übertragen

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread