Live-Forum - Die aktuellen Beiträge
Datum
Titel
20.04.2024 16:39:00
ältere VBA Codes automatisch neu strukturieren
20.04.2024 16:36:42
Arbeitsblatt Script auslagern in Modul
20.04.2024 16:28:25
zwei Makro in einem zusammenführen?
20.04.2024 15:30:14
Warum Verweis zeigt Falsch an
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1124to1128
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1124to1128
1124to1128
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zeile aufgrund Werte einfärben | Herbers Excel-Forum

Zeile aufgrund Werte einfärben
07.01.2010 09:39:59
Ben

Hallo Forum
Ich habe folgenden Code, um eine Zeile abhängig vom Wert in Spalte R, einzufärben:

Sub Zellenfarbe()
Dim rngZelle As Range, strText As String
ActiveSheet.Range("C6:D100").Interior.ColorIndex = 0
For Each rngZelle In ActiveSheet.Range("R1:R100")
Select Case rngZelle.Value
Case "a"
Range("C" & rngZelle.Row & ":D" & rngZelle.Row).Interior.ColorIndex = 2
Case "b"
Range("C" & rngZelle.Row & ":D" & rngZelle.Row).Interior.ColorIndex = 3
Case "c"
Range("C" & rngZelle.Row & ":P" & rngZelle.Row).Interior.ColorIndex = 37
Case "d"
Range("C" & rngZelle.Row & ":D" & rngZelle.Row).Interior.ColorIndex = 35
Case "e"
Range("C" & rngZelle.Row & ":P" & rngZelle.Row).Interior.ColorIndex = 6
Case "f"
Range("C" & rngZelle.Row & ":P" & rngZelle.Row).Interior.ColorIndex = 15
End Select
Next
End Sub
Das funktioniert, wenn ich das Makro manuell laufen lasse. Wie muss ich den Code anpassen, wenn das Färben gleich bei Veränderung des Wertes in Spalte R erfolgen soll? Irgendwie krieg ich das nicht richtig hin.
Vielen Dank und Gruss
Ben

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeile aufgrund Werte einfärben
07.01.2010 09:49:24
Josef Ehrensberger
Hallo Ben,
in das Modul der Tabelle.
' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rngZelle As Range, lngColor As Long
  
  If Not Intersect(Target, Range("C6:D100")) Is Nothing Then
    For Each rngZelle In Intersect(Target, Range("C6:D100"))
      Select Case rngZelle.Value
        Case "a":  lngColor = 2
        Case "b":  lngColor = 3
        Case "c":  lngColor = 37
        Case "d":  lngColor = 35
        Case "e":  lngColor = 6
        Case "f":  lngColor = 15
        Case Else:  lngColor = xlNone
      End Select
      Range("C" & rngZelle.Row & ":P" & rngZelle.Row).Interior.ColorIndex = lngColor
    Next
  End If
  
End Sub


Gruß Sepp
Anzeige
AW: Zeile aufgrund Werte einfärben
07.01.2010 09:50:03
Hajo_Zi
Hallo Ben,
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Range("C6:D100").Interior.ColorIndex = 0
Dim RaBereich As Range, RaZelle As Range
' Bereich der Wirksamkeit
Set RaBereich = Range("R1:R100")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
'ActiveSheet.Unprotect ("Passwort")
For Each RaZelle In RaBereich
Select Case RaZelle.Value
Case "a"
Range("C" & RaZelle.Row & ":D" & RaZelle.Row).Interior.ColorIndex = 2
Case "b"
Range("C" & RaZelle.Row & ":D" & RaZelle.Row).Interior.ColorIndex = 3
Case "c"
Range("C" & RaZelle.Row & ":P" & RaZelle.Row).Interior.ColorIndex = 37
Case "d"
Range("C" & RaZelle.Row & ":D" & RaZelle.Row).Interior.ColorIndex = 35
Case "e"
Range("C" & RaZelle.Row & ":P" & RaZelle.Row).Interior.ColorIndex = 6
Case "f"
Range("C" & RaZelle.Row & ":P" & RaZelle.Row).Interior.ColorIndex = 15
End Select
Next RaZelle
'ActiveSheet.protect ("Passwort")
End If
Set RaBereich = Nothing
End Sub
Unter der Tabelle.

Anzeige
AW: Zeile aufgrund Werte einfärben
07.01.2010 09:50:57
Tino
Hallo,
versuche es mal so.
kommt als Code in Tabelle 
Option Explicit 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
Dim rngZelle As Range, tmpZelle As Range 
 
Set rngZelle = Intersect(Range("C6:D100"), Target) 
 
For Each rngZelle In rngZelle 
    Set tmpZelle = Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)) 
    Select Case rngZelle.Value 
        Case "a": tmpZelle.Interior.ColorIndex = 2 
        Case "b": tmpZelle.Interior.ColorIndex = 3 
        Case "c": tmpZelle.Interior.ColorIndex = 37 
        Case "d": tmpZelle.Interior.ColorIndex = 35 
        Case "e": tmpZelle.Interior.ColorIndex = 6 
        Case "f": tmpZelle.Interior.ColorIndex = 15 
        Case Else: tmpZelle.Interior.ColorIndex = 0 
    End Select 
Next 
 
End Sub

Gruß Tino
Anzeige
Korrektur Eingabebereich und Bereich färben
07.01.2010 10:20:29
Tino
Hallo,
habe Deinen Code nicht richtig gelesen.
Die Eingabe erfolgt ja in Spalte R und bei a, b u. d wird nur von Spalte C bis D gefärbt und
die anderen bis Spalte P
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngZelle As Range

Set rngZelle = Intersect(Range("R6:R100"), Target)

For Each rngZelle In rngZelle
    
    Select Case rngZelle.Value
        Case "a"
            Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 2
        Case "b"
            Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 3
        Case "c"
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 37
        Case "d"
            Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 35
        Case "e"
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 6
        Case "f"
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 15
        Case Else
            Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
    End Select
Next

End Sub
Gruß Tino
Anzeige
AW: Korrektur Eingabebereich und Bereich färben
07.01.2010 10:26:42
Ben
Hi Tino
Danke schonmal.
Habe Deinen korrigierten Code soeben getestet. Ich erhalte die Fehlermeldung
Laufzeitfehler 424. Objekt erforderlich.
Nachdem ich auf "Debuggen" geklickt habe springt er auf
For Each rngZelle In rngZelle
Ansonsten hast Du den Sachverhalt bzgl. Eingabe und Einfärbung genau richtig eingeschätzt.
Gruss
Ben
eine If vergessen (nicht ausgeschlafen)
07.01.2010 10:27:22
Tino
Hallo,
so jetzt sollte es gehen.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngZelle As Range

Set rngZelle = Intersect(Range("R6:R100"), Target)

If Not rngZelle Is Nothing Then
    For Each rngZelle In rngZelle
        
        Select Case rngZelle.Value
            Case "a"
                Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 2
            Case "b"
                Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 3
            Case "c"
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 37
            Case "d"
                Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 35
            Case "e"
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 6
            Case "f"
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 15
            Case Else
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
        End Select
    Next
End If
End Sub
Gruß Tino
Anzeige
AW: eine If vergessen (nicht ausgeschlafen)
07.01.2010 10:57:50
Ben
Hi
Ich habe mich wohl etwas unklar ausgedrückt. Die eigentliche Eingabe erfolgt nicht in Spalte R sondern in Spalte D. In Spalte R wird - je nach Eingabe in Spalte D - a, b, c, d oder e als Resultat ausgegeben. Brauchts dazu nochmals eine Anpassung?
Ansonsten funktioniert dein Code genau so wie ich es haben sollte.
Gruss
Ben
demnach müsste es so funktionieren.
07.01.2010 11:28:07
Tino
Hallo,
teste mal mit diesem Code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngZelle As Range

'Eingabebereich Spalte D 
Set rngZelle = Intersect(Range("D6:D100"), Target)
'Wurde in Spalte D was eingebeben? 
If Not rngZelle Is Nothing Then
    'Schleife über die Eigebezellen in D 
    For Each rngZelle In rngZelle
        'Wert aus Zeile R in der Eingabezeile von D 
        Select Case Cells(rngZelle.Row, 18).Value
            Case "a"
                Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 2
            Case "b"
                Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 3
            Case "c"
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 37
            Case "d"
                Range(Cells(rngZelle.Row, 5), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 35
            Case "e"
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 6
            Case "f"
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 15
            Case Else
                Range(Cells(rngZelle.Row, 3), Cells(rngZelle.Row, 16)).Interior.ColorIndex = 0
        End Select
    Next
End If
End Sub
Gruß Tino
Anzeige
AW: demnach müsste es so funktionieren.
07.01.2010 11:40:23
Ben
Hi Tino
Ganz herzlichen Dank für die Hilfe. Jetzt passt es perfekt.
Gruss
Ben

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige