Microsoft Excel

Herbers Excel/VBA-Archiv

Zeile aufgrund Werte einfärben | Herbers Excel-Forum


Betrifft: Zeile aufgrund Werte einfärben von: Ben
Geschrieben am: 07.01.2010 09:39:59

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

  

Betrifft: AW: Zeile aufgrund Werte einfärben von: Josef Ehrensberger
Geschrieben am: 07.01.2010 09:49:24

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



  

Betrifft: AW: Zeile aufgrund Werte einfärben von: Hajo_Zi
Geschrieben am: 07.01.2010 09:50:03

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.

GrußformelHomepage


  

Betrifft: AW: Zeile aufgrund Werte einfärben von: Tino
Geschrieben am: 07.01.2010 09:50:57

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


  

Betrifft: Korrektur Eingabebereich und Bereich färben von: Tino
Geschrieben am: 07.01.2010 10:20:29

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


  

Betrifft: AW: Korrektur Eingabebereich und Bereich färben von: Ben
Geschrieben am: 07.01.2010 10:26:42

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


  

Betrifft: eine If vergessen (nicht ausgeschlafen) von: Tino
Geschrieben am: 07.01.2010 10:27:22

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


  

Betrifft: AW: eine If vergessen (nicht ausgeschlafen) von: Ben
Geschrieben am: 07.01.2010 10:57:50

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


  

Betrifft: demnach müsste es so funktionieren. von: Tino
Geschrieben am: 07.01.2010 11:28:07

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


  

Betrifft: AW: demnach müsste es so funktionieren. von: Ben
Geschrieben am: 07.01.2010 11:40:23

Hi Tino
Ganz herzlichen Dank für die Hilfe. Jetzt passt es perfekt.
Gruss
Ben