Gruppen

Top Gruppen: Windows 7; Windows Vista; Windows XP; Textverarbeitung; Excel; DSL; Internet Browser; E-Mail/Outlook
Betriebsysteme: Windows classik; Linux; BS-Sonstige
Software: Datenbanken; Bildbearbeitung; Audio/mp3/Video; Security/Viren; SW-Sonstige
Hardware: Mainboard/CPU; Grafikkarten; Peripherie; Laptop/Notebook; HW-Sonstiges
Netzwerk: Telefon,ISDN,Modem; W-Lan; NW-Sonstiges
Programmierung: PHP,ASP,Perl...; Java,C++...; Webseiten/HTML
Sonstiges: PC-Sonstiges; Plauderecke; SN Intern; Test

/ Forum / Skripte(PHP,ASP,Perl...)

Skripte(PHP,ASP,Perl...)

Fragevon Sascha555 vom 24.01.2019, 07:44 Options

Zellen in def. Bereich in Abhängigkeit von Zahlen färben

Hallo zusammen,

bestimmt kann mir jemand von Euch weiterhelfen!

Unten ist ein Makro abgebildet, bei dem definiert werden kann wie sich die Zelle im Tabellenblatt bei Eingabe einer bestimmten Zahl färben soll. So kann z. B. definiert werden, dass sich eine Zelle automatisch rot einfärbt (Case 3 Target.Interior.ColorIndex = 3), wenn ein bestimmter Wert (in dem Fall 3) eingegeben wird.

* 1 - Schwarz
* 2 - Weiss
* 3 - Rot
* 4 - Grün
* 5 - Blau
* 6 - Gelb

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Select Case Target.Value
Case 1
Target.Interior.ColorIndex = 1
Case 2
Target.Interior.ColorIndex = 2
Case 3
Target.Interior.ColorIndex = 3
Case 4
Target.Interior.ColorIndex = 4
Case 5
Target.Interior.ColorIndex = 5
Case 6
Target.Interior.ColorIndex = 6
Case Else
Target.Interior.ColorIndex = xlColorIndexNone
End Select
End Sub

Ich benötige das Makro in folgender Form:

„kleiner/gleich“ 5% = grün (4)
„größer/gleich“ -5% = grün (4)
„kleiner/gleich“ 8% = gelb (6)
„größer/gleich“ -8% = gelb (6)
„größer als“ 8% = rot (3)
„kleiner als“ -8% = rot (3)

... und das ganze für die Zellen "A1:A20" und "D1:D20"

Vielen Dank für Eure Antworten

Gruß

Sascha

Antwort schreiben

Antwort 1 von Bert vom 24.01.2019, 13:32 Options

Hallo

Hoffe es tut das was Du willst:

[b]
Option Explicit

Private Sub Worksheet_Calculate()
Rem Für berechnete Werte
Dim r As Integer, c As Integer
Rem für die Bereiche "A1:A20" und "D1:D20"
For r = 1 To 4 Step 3
For c = 1 To 20
Select Case Abs(Cells(c, r).Value)
Case 0
 Cells(c, r).Interior.ColorIndex = 0: Rem Neutral
Case 0.05
Cells(c, r).Interior.ColorIndex = 4: Rem grün
Case 0.05 To 0.08
   Rem Wert =8% oder -8%
 Cells(c, r).Interior.ColorIndex = 6: Rem Gelb
Case Is > 0.08
   Rem Wert > + -8%
 Cells(c, r).Interior.ColorIndex = 3: Rem Rot
Case Else
   Rem Wert ist kleiner/gleich 5%
 Cells(c, r).Interior.ColorIndex = 4: Rem grün
End Select
Next: Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   Rem auf zuläßige Bereiche prüfen
If Target.Row > 20 Or Target.Column > 4 Then Exit Sub
   Rem Wenn zeile>20 oder Spalte >4 prog verlassen
If Target.Column = 2 Or Target.Column = 3 Then Exit Sub
   Rem Wenn spalte =2("B") oder Spalte =3 ("C") prog verlassen
Select Case Abs(Target.Value)
Case 0
Target.Interior.ColorIndex = 0: Rem Neutral
Case 0.05
 Target.Interior.ColorIndex = 4: Rem grün
Case 0.05 To 0.08
   Rem Wert =8% oder -8%
 Target.Interior.ColorIndex = 6: Rem Gelb
Case Is > 0.08
   Rem Wert > + -8%
 Target.Interior.ColorIndex = 3: Rem Rot
Case Else
   Rem Wert ist kleiner/gleich 5%
 Target.Interior.ColorIndex = 4: Rem grün
End Select
End Sub

[/b]
Gruß Bert

Hinweis

Diese Frage ist schon etwas älter, Sie können daher nicht mehr auf sie antworten. Sollte Ihre Frage noch nicht gelöst sein, stellen Sie einfach eine neue Frage im Forum..

Neue Einträge

Tipp einschicken

News einschicken