Microsoft Excel

Herbers Excel/VBA-Archiv

Farbenproblem | Herbers Excel-Forum


Betrifft: Farbenproblem von: Uli
Geschrieben am: 11.11.2009 21:42:47

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

  

Betrifft: AW: Farbenproblem von: Daniel
Geschrieben am: 11.11.2009 21:57:21

Hi
probiers mal so (vom Prinzip her)

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
die Intersect-Funktion verhindert übermässige Wartezeiten, wenn du mal die ganze Spalte oder alle Zellen markiert hast.

etwas eleganter wäre die Programmierung, wenn du statt IF-ELSEIF die SELECT CASE-Funktion verwendest.
ebenso ist in diesem Fall die LCASE-Funktion hilfreich, die alle Buchstaben in Kleinbuchstaben umwandelt, was die prüfung ebenfalls vereinfacht.
Dein Code sähe dann so aus:
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
Gruß, Daniel

Gruß, Daniel


  

Betrifft: Hier erst mal eine Straffung deiner... von: Luc:-?
Geschrieben am: 11.11.2009 22:45:05

...bisherigen Prozedur, Ulrich,
da sollte es dann leichter fallen, noch Änderungen einzubauen. Allerdings ist hier ja schon weiß enthalten (Case Else), wenn die Zelle nicht passend signiert ist, also auch, wenn sie leer ist...

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

Warum soll das Auswählen (ohne Änderung) und anschließendes „Ziehen“ eigentlich nicht schon jetzt klappen...? Ach ja, ein ganzer Bereich... Das ist dann ein Feld und kann nicht mit String-Fktt bearbeitet wdn. IsArray(...) muss also noch abgefragt wdn — mal als Tipp...! Das kannst du nach der Marke Fehlerwert tun oder gleich als Target-Abfrage einbauen...
Gruß Luc :-?