Office: [Excel2k] Ampelschaltung mit einer Eingabe

Huhu, ich schon wieder und meine Wünsche werden komplizierter.

Ich habe in diversen Excel-Tabellen eine Art Statusampel mit den Farben rot, gelb und grün. Aufgebaut ist sie aus 3 nebeneinanderliegenden Zellen, die jeweils mit 1 auf die jeweilige Farbe geschaltet werden und mit 0 wieder auf weiss. D.h. ein Statuswechsel bedingt zwei Eingaben, nämlich einmal die 1 auf den neuen Status sowie die 0, um den alten Status wieder weiss zu machen. Nun würde ich das gerne automatisieren.
Die Eingabe der 1 in einem der drei Zellen soll die andere Zellen automatisch auf weiss setzen. Mit der bedingten Formatierung komme ich nicht so recht weiter, da ich da ja nicht die Farbe anderer Zellen ändern kann, als die jeweils aktive.

Vielleicht noch mal in Pseudocode:

Code:

     IF Feld A1 = 1 THEN Feld A2=0 AND A3 = 0
ELSE IF Feld A2 = 1 THEN Feld A1=0 AND A3 = 0
ELSE IF Feld A3 = 1 THEN Feld A1=0 AND A1 = 0
FI

 

Ich habe es alleine hinbekommen, aber um die zahlreichen Experten hier trotzdem anzuzapfen, würde mich interessieren, ob ich den Code nicht deutlich schlanker bekomme:

So sieht mein Code momentan aus:

Teil 1:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

    ' Variablendeklaration
    Dim Bereich As Range, ampelBereich As Range, Zelle As Range

    ' Abschalten der Excel-Events
    Application.EnableEvents = False

    ' Definition des jeweils betreffenden Bereiches
    ' und Aufruf der Umwandelfunktion
    Set Bereich = Range("C8:C47")
    Call toUppercase(Bereich, Target)
    
    Set ampelBereich = Range("I8:K47")
    Call schalteAmpel(ampelBereich, Target)
    
    ' Wiedereinschalten der Excel-Events
    Application.EnableEvents = True

End Sub

Teil 2 (Ampelschaltung):

Code:

Private Sub schalteAmpel(Bereich As Range, Target As Range)
    
    Dim bereichGruen As Range, bereichGelb As Range, bereichRot As Range
    
    Set bereichGruen = Range("I8:I48")
    Set bereichOrange = Range("J8:J48")
    Set bereichRot = Range("K8:K48")

    If Not Intersect(Target, Bereich) Is Nothing Then
        If Not Intersect(Target, bereichGruen) Is Nothing Then
            Select Case (Target.Value)
                Case "1":
                    Target.Cells.Interior.ColorIndex = 4 'gruen
                    Target.Cells.Font.ColorIndex = 4
                    Target.Offset(0, 1).Cells.Interior.ColorIndex = 2
                    Target.Offset(0, 1).Font.ColorIndex = 2
                    Target.Offset(0, 2).Cells.Interior.ColorIndex = 2
                    Target.Offset(0, 2).Font.ColorIndex = 2
            End Select
        End If
        
        If Not Intersect(Target, bereichOrange) Is Nothing Then
            Select Case (Target.Value)
                Case "1":
                    Target.Cells.Interior.ColorIndex = 45 'orange
                    Target.Cells.Font.ColorIndex = 45
                    Target.Offset(0, -1).Cells.Interior.ColorIndex = 2
                    Target.Offset(0, -1).Font.ColorIndex = 2
                    Target.Offset(0, 1).Cells.Interior.ColorIndex = 2
                    Target.Offset(0, 1).Font.ColorIndex = 2
            End Select
        End If
        
        If Not Intersect(Target, bereichRot) Is Nothing Then
            Select Case (Target.Value)
                Case "1":
                    Target.Cells.Interior.ColorIndex = 3 'rot
                    Target.Cells.Font.ColorIndex = 3
                    Target.Offset(0, -1).Cells.Interior.ColorIndex = 2
                    Target.Offset(0, -1).Font.ColorIndex = 2
                    Target.Offset(0, -2).Cells.Interior.ColorIndex = 2
                    Target.Offset(0, -2).Font.ColorIndex = 2
            End Select
        End If
    End If

End Sub

 

Hallo!

Das ist nicht richtig!

Markiere A2 und gib bei der bedingten Formatierung dies ein:
Formel ist: =A1=1
(Format: grün)

Nun färbt sich A2 grün, wenn in A1 eine Eins steht.

 

Hmm, ich breche mir hier mit meinen rudimentären VBA-Kenntnissen einen ab, dabei ist es so einfach.

Eigentlich müsste ich nun wieder die ASCII-Rosen bringen, aber ich belasse es mal bei einem fetten Danke!