zellen in einem Bereich färben

Hallo,
ich such nach einem Makro, das folgende Funktion durchführen sollte.
Wenn in einem bestimmten Bereich der Zellinhalt größer 0 ist, dann prüfe, ob in einer bestimmten Zelle, die in derselben Zeile wie die Werte steht, aber außerhalb des Bereichs ist, ob in dieser Zelle z.B. das Wort Auto steht.
Es soll vier Varianten zur Auswahl geben (z.B. Haus, Auto, Bild, Buch).
Wenn haus dort steht, soll die Zellen (mit Wert größer 0), in der betreffenden Zeile, z.B. rot gefärbt werden,
Wenn Auto steht, z.B. gelb, bei Bild grün, bei Buch blau und wenn kein Wert in der abgefragten Zelle zu finden ist, soll es farblos bleiben.
Dann soll die nächste Zeile überprüft werden, bis der ganze Bereich auf diese Weise überprüft wurde.
Wer könnte mir hier ein bisschen weiter helfen.
Vielen Dank schon mal
Gruß Jonatan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Const tThisRange = "G2:G10" Const iThatOffset = -5 If Intersect(Target, ActiveSheet.Range(tThisRange)) Is Nothing Or _ Target.Cells.Count > 1 Then Exit Sub Select Case LCase(Target.Value) Case "haus" Target.Offset(0, iThatOffset).Interior.ColorIndex = 3 Case "auto" Target.Offset(0, iThatOffset).Interior.ColorIndex = 4 Case "bild" Target.Offset(0, iThatOffset).Interior.ColorIndex = 5 Case "buch" Target.Offset(0, iThatOffset).Interior.ColorIndex = 6 Case Else Target.Offset(0, iThatOffset).Interior.ColorIndex = xlColorIndexNone End Select End Sub

Hi Jonatan,
welche Zellen werden dann gefärbt. die Zelle 5 Spalten links von Spalte G, sprich Spalte B
Was bedeutet "Target.Cells.Count größer 1 es wird geprüft ob genau eine Zelle verändert wurde.
sondern mehrere Spalten sind, dann z.B. so:


Private Sub Worksheet_Change(ByVal Target As Range)
Const tThisRange = "G2:G10"         ' Bereich der EingabeZellen
Const iThatOffset = -5              ' Offset zum Bereich in Spalten (links-,rechts+)
Const iNrofColumns = 3              ' Anzahl Spalten nach rechts ab Offsetspalte
Dim lx As Long
If Intersect(Target, ActiveSheet.Range(tThisRange)) Is Nothing Or _
Target.Cells.Count > 1 Then Exit Sub
Select Case LCase(Target.Value)
Case "haus"
For lx = iThatOffset To iThatOffset + iNrofColumns - 1
Target.Offset(0, lx).Interior.ColorIndex = 3
Next lx
Case "auto"
For lx = iThatOffset To iThatOffset + iNrofColumns - 1
Target.Offset(0, lx).Interior.ColorIndex = 4
Next lx
Case "bild"
For lx = iThatOffset To iThatOffset + iNrofColumns - 1
Target.Offset(0, lx).Interior.ColorIndex = 5
Next lx
Case "buch"
For lx = iThatOffset To iThatOffset + iNrofColumns - 1
Target.Offset(0, lx).Interior.ColorIndex = 6
Next lx
Case Else
For lx = iThatOffset To iThatOffset + iNrofColumns - 1
Target.Offset(0, lx).Interior.ColorIndex = xlColorIndexNone
Next lx
End Select
End Sub

GreetZ Renée

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread