1.6k Aufrufe
Gefragt in Tabellenkalkulation von petra65 Experte (1.8k Punkte)
Hallo, hallo,

ich habe ein Problem mit der Erstellung eines Makros, und finde
leider keine Lösung ..... folgendes:

in den Zellen C5 bis CZ5 stehen 6 unterschiedliche
Buchstabenkürzel, z. B. SR oder PH oder AH oder ....

Die Spalten darunter, z. B. C6 bis C32 werden nach Bedarf mit
einem x gefüllt.

Ich möchte nun folgendes:
ist in C5 ein SR vorhanden und in C10 ein x, dann soll die
Hintergrundfarbe z. B. rot sein.

Mein Problem ist die Abfrage auf das Kürzel ....


Mein Code sieht bisher folgendermaßen aus:



Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim RaBereich As Range
Dim RaZelle As Range
Set RaBereich = Range("C5:EZ32")

Set RaBereich = Intersect(RaBereich, Range(Target.Address))

If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
With RaZelle
Case "SR"
.Interior.Color = 0
Case "PH"
.Interior.Color = 65535
Case "SK"
.Interior.Color = 255
Case "AW"
.Interior.Color = 65280
Case "RLB"
.Interior.Color = 16711680
Case "AH"
.Interior.Color = 16711680
Case "SP"
.Interior.Color = 16711680
Case Else
.Interior.ColorIndex = xlNone
End Select
End With
Next RaZelle
End If
Set RaBereich = Nothing
End Sub


Ich hoffe, dass mir jemand "auf die Sprünge" helfen kann ???


Vielen Dank schonmall

Petra

3 Antworten

0 Punkte
Beantwortet von kauz Mitglied (291 Punkte)
Hallo Petra,
hab es mal etwas geändert...

Sicher nicht die eleganteste Lösung...
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Y As Integer
Dim X As Integer
Dim RaBereich As Range
Dim RaZelle As Range
Set RaBereich = Range("C5:EZ32")

Set RaBereich = Intersect(RaBereich, Range(Target.Address))

If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
With RaZelle
Y = Target.Row ' aktuelle Zeilennummer
X = Target.Column ' aktuelle Spaltennummer merken
MsgBox Cells(10, X) 'Inhalt Zeile 10 , aktuelle Spalte
If RaZelle = "SR" And Cells(10, X) = "x" Then
.Interior.Color = 0
ElseIf RaZelle = "PH" And Cells(10, X) = "x" Then
.Interior.Color = 65535
ElseIf RaZelle = "SK" And Cells(10, X) = "x" Then
.Interior.Color = 255
ElseIf RaZelle = "AW" And Cells(10, X) = "x" Then
.Interior.Color = 65280
ElseIf RaZelle = "RLB" And Cells(10, X) = "x" Then
.Interior.Color = 16711680
ElseIf RaZelle = "AH" And Cells(10, X) = "x" Then
.Interior.Color = 16711680
ElseIf RaZelle = "SP" And Cells(10, X) = "x" Then
.Interior.Color = 16711680
Else
.Interior.ColorIndex = xlNone
End If
End With
Next RaZelle
End If
Set RaBereich = Nothing
End Sub


Die Farben werden jetzt nur aktiv, wenn in Zeile 10 der gleichen
Spalte ein "x" steht.

Vielleicht ist es für Dich ja ausbaufähig...

Grüße
Andreas
0 Punkte
Beantwortet von petra65 Experte (1.8k Punkte)
Hallo, guten Morgen ....

ich weiss nicht ob elegant oder nicht - aber es funktioniert.

Musste nur einige Kleinigkeiten ändern.

Der Code sieht nun so aus:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Y As Integer
Dim X As Integer
Dim RaBereich As Range
Dim RaZelle As Range
Set RaBereich = Range("C5:EZ32")

Set RaBereich = Intersect(RaBereich, Range(Target.Address))

If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
With RaZelle
Y = Target.Row ' aktuelle Zeilennummer
X = Target.Column ' aktuelle Spaltennummer merken

If RaZelle = "x" And Cells(5, X) = "SR" Then
.Interior.Color = RGB(255, 128, 128)
ElseIf RaZelle = "x" And Cells(5, X) = "PH" Then
.Interior.Color = RGB(204, 128, 255)
ElseIf RaZelle = "x" And Cells(5, X) = "SK" Then
.Interior.Color = RGB(51, 204, 204)
ElseIf RaZelle = "x" And Cells(5, X) = "AW" Then
.Interior.Color = RGB(255, 255, 153)
ElseIf RaZelle = "x" And Cells(5, X) = "RLB" Then
.Interior.Color = RGB(255, 204, 0)
ElseIf RaZelle = "x" And Cells(5, X) = "AH" Then
.Interior.Color = RGB(150, 150, 150)
ElseIf RaZelle = "x" And Cells(5, X) = "SP" Then
.Interior.Color = RGB(0, 255, 255)
Else
.Interior.ColorIndex = xlNone
End If
End With
Next RaZelle
End If
Set RaBereich = Nothing
End Sub



Vielen Dank für die Hilfe

Gruss Petra
0 Punkte
Beantwortet von kauz Mitglied (291 Punkte)
Hallo Petra,
freut mich, das es geklappt hat.

Danke für die Rückmeldung.

Gruß
Andreas
...