Farbenproblem

Hallo,
ich habe folgende Programmierung vorgenommen:


Private Sub Worksheet_Change(ByVal Target As Range)     'Tritt ein, wenn Zellen des  _
Arbeitsblattes durch den Benutzer oder durch eine externe Verknüpfung geändert werden.
On Error GoTo Fehlerwert                                'Fehlerbehandlungsroutine, die  _
aufgerufen wird, wenn ein Fehler auftritt und zum Feld Fehlerwert springt
If Target.Value = "VT" Or Target.Value = "vt" Or Target.Value = "Vt" Then     'Wenn in dem   _
_
_
_
gerade geprüften Feld die Buchstaben "VT" stehen
Target.Interior.ColorIndex = 16                      'Markiere dieses Feld in Farbe 16 (  _
_
_
_
grau)
ElseIf Target.Value = "T" Or Target.Value = "t" Then
Target.Interior.ColorIndex = 4
ElseIf Target.Value = "FT" Or Target.Value = "ft" Or Target.Value = "Ft" Then
Target.Interior.ColorIndex = 12
ElseIf Target.Value = "K" Or Target.Value = "k" Then
Target.Interior.ColorIndex = 53
ElseIf Target.Value = "TL" Or Target.Value = "tl" Or Target.Value = "Tl" Then
Target.Interior.ColorIndex = 25
ElseIf Target.Value = "FB" Or Target.Value = "fb" Or Target.Value = "Fb" Then
Target.Interior.ColorIndex = 11
ElseIf Target.Value = "UE" Or Target.Value = "ue" Or Target.Value = "Ue" Then
Target.Interior.ColorIndex = 9
ElseIf Target.Value = "R" Or Target.Value = "r" Then
Target.Interior.ColorIndex = 5
ElseIf Target.Value = "F" Or Target.Value = "f" Then
Target.Interior.ColorIndex = 3
Else:
Target.Interior.ColorIndex = 2      'Falls keiner der Buchstaben in den Feldern, färbe   _
_
_
_
den Zellenhintergrund weiß
End If
Exit Sub
Fehlerwert:         'hierhin wird gewechselt, falls ein Fehler auftritt
End Sub

In dieser Datei wird überprüft, ob in der gerade markierten, aktiven Zelle, die angegebenen Buchstabenkürzungen stehen.
Stehen die Werte dort, markiert das Programm Sie automatisch in der richtigen Farbe.
Ich möchte eine Verbesserung einfügen:
Wenn ich mehrere Zellen lösche, sollen auch die Zellen im Hintergrund wieder weiß werden.
Dies funktioniert derzeit nur mit einer einzelnen markierten Zelle.
Dabei muss die Kopierfunktion, d.h. dass ich eine Zelle markiere und den Inhalt "runterziehen" kann, erhalten bleiben.
Über Hilfe wäre ich sehr dankbar.
Viele Grüße
Ulrich Heisterkamp

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub Worksheet_Change(ByVal Target As Range) dim Zelle as Range For Each Zelle in Intersect(Target, Activesheet.Usedrange) jetzt deinen Code einfügen, dabei aber jedes Target durch Zelle ersetzen Next End Sub

Private Sub Worksheet_Change(ByVal Target As Range) dim Zelle as Range For Each Zelle in Intersect(Target, Activesheet.Usedrange) Select Case LCase(Zelle.Value) Case "t" .Interior.ColorIndex = 4 Case "ft" .Interior.ColorIndex = 12 Case ... Case Else .Interior.Colorindex = xlNone End Select Next End Sub

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehlerwert With Target.Interior Select Case LCase(Target) Case "vt": .ColorIndex = 16 Case "t": .ColorIndex = 4 Case "ft": .ColorIndex = 12 Case "k": .ColorIndex = 53 Case "tl": .ColorIndex = 25 Case "fb": .ColorIndex = 11 Case "ue": .ColorIndex = 9 Case "r": .ColorIndex = 5 Case "f": .ColorIndex = 3 Case Else: .ColorIndex = 2 End Select End With Exit Sub Fehlerwert: 'hierhin wird gewechselt, falls ein Fehler auftritt End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread