Bestimmter Wert - Bestimmte Zellfarbe

Computer: Software & Programmierung Visual Basic
#1

Hallo VBA Freunde,
ich habe hier einen Code geschrieben der beim Zellwert „RE“ die Zelle
im Colorindex „7“ färbt. Das funzt prima.
Jetzt sollen aber die Zellen, wenn ein anderer Wert eingegeben wird, wieder ihre vorherige Farbe annehmen. Die Zellen sind vorher entweder Colorindex „2“ oder „36“.
Wie kann ich die vorherige Zellfarbe speichern??
Für jede Hilfe mein Dank im Voraus.
Gruß Skaletti!

Private Sub Worksheet\_Change(ByVal Target As Range)
Dim rngCell As Range
Dim rngBereich As Range
Set rngBereich = Range("B6:AF93")
For Each rngCell In rngBereich
Select Case rngCell.Value
Case "RE"
rngCell.Interior.ColorIndex = 7
End Select
Next
End Sub
#2

Hallo Skaletti,

der pre-Tag nimmt dir nicht ab selbst für die Einrückungen im Code zu sorgen :smile:

Den Code schaue ich mir nachher an, muß nochmal weg.
Oder Rainer löst das Problem, er verliebt sich ja zunehmend in Excel obwohl er da eine sehr seltsame Excelversion hat *lächel*

Gruß
Reinhard

#3

Hallo Reinhard,
Danke für deine Antwort.
Habe hier eine Lösung mit der Festlegung der einzelnen „Ranges“.
Das wird warscheinlich kürzer gehen. Oder??

Private Sub Worksheet\_Change(ByVal Target As Range)
Dim rngCell As Range
Dim rngBereich As Range
Set rngBereich = Range("B6:B93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 22
 End Select
Next
Set rngBereich = Range("C6:smiley:93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 36
 End Select
Next
Set rngBereich = Range("E6:I93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 2
 End Select
Next
Set rngBereich = Range("J6:K93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 36
 End Select
Next
Set rngBereich = Range("L6:stuck\_out\_tongue:93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 2
 End Select
Next
Set rngBereich = Range("Q6:R93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 36
 End Select
Next
Set rngBereich = Range("S6:W93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 2
 End Select
Next
Set rngBereich = Range("X6:Y93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 36
 End Select
Next
Set rngBereich = Range("Z6:AD93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 2
 End Select
Next
Set rngBereich = Range("AE6:AF93")
 For Each rngCell In rngBereich
 Select Case rngCell.Value
 Case "RE"
 rngCell.Interior.ColorIndex = 7
 Case Else
 rngCell.Interior.ColorIndex = 36
 End Select
Next
End Sub
#4

Habe hier eine Lösung mit der Festlegung der einzelnen
„Ranges“.
Das wird warscheinlich kürzer gehen. Oder??

Hallo Skaletti,

laß die Prozedur tt einmalig laufen, danach brauchst du sie nicht mehr, dann macht das die Change-Prozedur.

In Modul1:

Sub tt()
Dim rngCell As Range, rngBereich As Range
Set rngBereich = Range("B6:B93,E6:I93,L6:stuck\_out\_tongue:93,S6:W93,Z6:AD93")
rngBereich.Interior.ColorIndex = 2
For Each rngCell In rngBereich
 If UCase(rngCell.Value) = "RE" Then rngCell.Interior.ColorIndex = 7
Next rngCell
Set rngBereich = Range("C6:smiley:93,J6:K93,Q6:R93,X6:Y93,AE6:AF93")
rngBereich.Interior.ColorIndex = 36
For Each rngCell In rngBereich
 If UCase(rngCell.Value) = "RE" Then rngCell.Interior.ColorIndex = 7
Next rngCell
End Sub

Im Modul des Blattes:

Private Sub Worksheet\_Change(ByVal Target As Range)
Dim rngCell As Range, rngBereich As Range
Set rngBereich = Intersect(Target, Range("B6:B93,E6:I93,L6:stuck\_out\_tongue:93,S6:W93,Z6:AD93"))
If Not rngBereich Is Nothing Then
 For Each rngCell In rngBereich
 rngCell.Interior.ColorIndex = IIf(UCase(rngCell.Value) = "RE", 7, 2)
 Next rngCell
End If
Set rngBereich = Intersect(Target, Range("C6:smiley:93,J6:K93,Q6:R93,X6:Y93,AE6:AF93"))
If Not rngBereich Is Nothing Then
 For Each rngCell In rngBereich
 rngCell.Interior.ColorIndex = IIf(UCase(rngCell.Value) = "RE", 7, 36)
 Next rngCell
End If
End Sub

Gruß
Reinhard

#5

Hallo Reinhard,
eine tolle Sache.
Du hast es drauf!
Vielen Dank für diese perfekte Lösung.

Gruß Skaletti!