---

Hallo,

habe eine Tabelle, in der in einer Spalte (Spalte K) Berechnungen erfolgen. Nun möchte ich dass wenn in der Spalte K ein Wert zw. 1-100 errechnet wurde, sich die Textfarbe ändert. Dann weiter 101-200 wieder andere Farbe, Wert: 201-300 nochmal eine andere Farbe. Und das alles bis 1000, jedesmal eine andere Farbe. Ich weiß, dass hierzu ein VBA benötigt wird. Da ich davon absolut keine Ahnung habe, nutzen mir auch die gefundenen Beispiele nichts, da ich nicht weiß, wo ich was auf meine Bedürfnisse ändern muss. Kann mir jemand von euch helfen? Das wäre echt super.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

hmmm,

Code:

---

Sub Farben()
Dim c As Range, arr, colarr, z As Byte
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) 'wertearray für überprüfung rz = arr(z)
colarr = Array(1, 3, 4, 5, 6, 7, 8, 9, 10, 11) 'hier bessere Farbwerte eintragen
'For Each c In Cells.SpecialCells(xlCellTypeConstants, 1) 'test über gesamte Blatt - Zahlen only
For Each c In Range("K1:K50") 'hier zeilen anpassen
For z = 0 To 9 'schleife
  rz = Round(((c + 50) / 100), 0) 'Zellwert wird auf 1 Ziffer gestutzt
'some test   
'If rz = arr(z) Then c.Interior.ColorIndex = rz + 2 ' hintergrund und Farbe +2
    'If rz = arr(z) Then c.Font.ColorIndex = rz + 2 ' Font und Farbe +2
    'If rz = arr(z) Then c.Interior.ColorIndex = colarr(z) 'Farbe aus colarr
'einfärben der Schrift
    If rz = arr(z) Then c.Font.ColorIndex = colarr(z) 'Farbe aus colarr
  Next
Next
End Sub

---

------------------
Am Anfang war kein Licht - und Vater blickte Kalt
Miss Brauch

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo MBaumi!

Hallo Thomas! Ganz schön kompliziert, was Du da machst. Ist toll und allgemein, aber für den Laien vielleicht nicht unbedingt nachvollziehbar...und er sagt ja, daß er "von VBA absolut keine Ahnung hat"

in einfacher sähe das z.B. auch so aus:
das ist zwar bedeutend länger und nicht so schön, aber vielleicht verständlicher und leichter anzupassen...

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objCell As Range
    For Each objCell In Target
        If Not Intersect(objCell, Range("K1:K10000")) Is Nothing Then
            With objCell
                Select Case .Value
                    Case 1 To 100
                        .Font.Name = "Arial"
                        .Font.Size = 14
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 2
                    Case 101 To 200
                        .Font.ColorIndex = 2  'Schriftfarbe = weiß
                        .Interior.ColorIndex = 3  'Hintergrundfarbe = rot
                    Case 201 To 300
                        .Font.ColorIndex = 3
                    Case 301 To 400
                        .Font.ColorIndex = 4
                    Case 401 To 500
                        .Font.ColorIndex = 5
                    Case 501 To 600
                        .Font.ColorIndex = 6
                    Case 601 To 700
                        .Font.ColorIndex = 7
                    Case 701 To 800
                        .Font.ColorIndex = 8
                    Case 801 To 900
                        .Font.ColorIndex = 9
                    Case 901 To 1000
                        .Font.ColorIndex = 10
                    Case Else
                        .Font.ColorIndex = 11
                End Select
            End With
        End If
    Next
End Sub

---

wie Du bei 1-100 siehst, kannst Du viele Sachen gleichzeitig zuweisen, wie Schriftname, -größe, -farbe, Hintergrundfarbe und vieles mehr, einfach dazwischenfummeln und ausprobieren.

um Dir die Farben mal anzeigen zu lassen führst Du folgendes Makro aus: (einfach in "diese Arbeitsmappe" oder ein Modul kopieren und "Makros ausführen" -> "Farbtabelle")

Code:

---

Sub Farbtabelle()
Dim bfarbe As Byte
For bfarbe = 2 To 57
If bfarbe < 30 Then
Cells(bfarbe, 1) = bfarbe - 1
Cells(bfarbe, 2).Interior.ColorIndex = bfarbe - 1
Cells(bfarbe, 3).Font.ColorIndex = bfarbe - 1
Cells(bfarbe, 3) = bfarbe - 1
Else
Cells(bfarbe - 28, 5) = bfarbe - 1
Cells(bfarbe - 28, 6).Interior.ColorIndex = bfarbe - 1
Cells(bfarbe - 28, 7).Font.ColorIndex = bfarbe - 1
Cells(bfarbe - 28, 7) = bfarbe - 1
End If
Next bfarbe
End Sub

---

Gruß,
Nicole

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Vielen herzlichen Dank für eure Mühe. Ich werde mir das ausdrucken und zur Gemüte ziehen. Liebe Nicole, auch dir vielen Dank für dein verständliches Angebot. Ihr habt mir sehr geholfen.

Mandy aus Berlin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Liebe Nicole,

habe gerade ein bisschen rumprobiert mit deinem Code. Vielleicht kannst du mir noch einmal helfen. Wie aktualisiert Excel automatisch. Ich muss jedesmal in meiner Spalte K die Formel neu eingeben, damit die Farbveränderung anerkannt wird. Weiterhin wird meine Formatierung auf Standardzahl in dieser Spalte jedesmal wieder geändert.

Ich hoffe ich nerve nicht zuviel.

LG, Mandy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Mandy!

Code:

---

Private Sub Worksheet_Activate()
    ApplicationUpdate = False
    Dim objCell As Range
    Set Target = Range("K1:K1000")
    For Each objCell In Target
        If Not Intersect(objCell, Range("K1:K1000")) Is Nothing Then
            With objCell
                Select Case .Value
                    Case 1 To 100
                        .NumberFormat = "General"
                        .Font.Name = "Arial"
                        .Font.Size = 14
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 1
                    Case 101 To 200
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 3
                    Case 201 To 300
                        .NumberFormat = "General"
                        .Font.ColorIndex = 3
                    Case 301 To 400
                        .NumberFormat = "General"
                        .Font.ColorIndex = 4
                    Case 401 To 500
                        .NumberFormat = "General"
                        .Font.ColorIndex = 5
                    Case 501 To 600
                        .NumberFormat = "General"
                        .Font.ColorIndex = 6
                    Case 601 To 700
                        .NumberFormat = "General"
                        .Font.ColorIndex = 7
                    Case 701 To 800
                        .NumberFormat = "General"
                        .Font.ColorIndex = 8
                    Case 801 To 900
                        .NumberFormat = "General"
                        .Font.ColorIndex = 9
                    Case 901 To 1000
                        .NumberFormat = "General"
                        .Font.ColorIndex = 10
                    Case Else
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = none
                End Select
            End With
        End If
    Next
    ApplicationUpdate = True
End Sub

---

nun müßte es aktualisieren, wenn Du das Tabellenblatt aktivierst.
mit der Zeile .NumberFormat = "General" weist Du das Standard-Format zu.

[edit]                    Case Else
                        .NumberFormat = "General"
                        .Font.ColorIndex = von "28" in "1" geändert
                        .Interior.ColorIndex = none  'Zeile hinzugefügt [/edit]

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

[Diese Nachricht wurde von runkelruebe am 26. Apr. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Liebe Nicole,

vielen Dank erneut. Kann es sein, dass Excel die Formel in meiner Spalte K nicht mag (=heute()-J5+1).

Wenn ich nur die Zahl eingebe, funktioniert alles prima. Sobald aber die Formal drin steht, mag er es nicht mehr.

LG, Mandy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

versteh' ich nicht, bei mir macht er's einwandfrei...
wechsel mal das Tabellenblatt und wieder zurück. Der code springt nur an, wenn Du das Blatt aktivierst, d.h. wenn Du was geändert hast, mußt Du einmal raus aus dem Blatt und wieder rein, dann aktualisiert es.
Aber mit Deiner Formel werden doch immer Zahlen > 1000 errechnet... Stimmt denn da die Formatierungsbedingung überhaupt?

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

mmh, also ich habe in der Spalte J mein Datum. Es wird auch die Spalte K berechnet und sobald ich J ändere auch die errechnete Zahl angezeigt. Wenn ich dann die Datei schließe und wieder öffne, ist die Formatierung nicht aktualisiert.

Hier mein (ne dein ) code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objCell As Range
    For Each objCell In Target
        If Not Intersect(objCell, Range("K1:K10000")) Is Nothing Then
            With objCell
                Select Case .Value
                Case 0
                        .NumberFormat = "General"
                        .Font.Name = "Arial"
                        .Font.Size = 10
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 2
                    Case 1 To 30
                        .NumberFormat = "General"
                        .Font.Name = "Arial"
                        .Font.Size = 10
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 19
                    Case 31 To 60
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1  'Schriftfarbe = weiß
                        .Interior.ColorIndex = 36  'Hintergrundfarbe = rot
                        .Font.Name = "Arial"
                    Case 61 To 90
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 6
                        .Font.Name = "Arial"
                    Case 91 To 120
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 44
                        .Font.Name = "Arial"
                    Case 121 To 150
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 45
                        .Font.Name = "Arial"
                    Case 151 To 180
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 46
                        .Font.Name = "Arial"
                    Case 181 To 250
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 3
                        .Font.Name = "Arial"
                    Case 251 To 360
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 54
                        .Font.Name = "Arial"
                    Case 361 To 1000
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 53
                        .Font.Name = "Arial black"
                       
                       
                    Case Else
                        .Font.ColorIndex = 11
                End Select
            End With
        End If
    Next
    ApplicationUpdate = True
End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ah, Du bist noch in der Sub Worksheet_Change. Die springt an, wenn eine Änderung im Blatt passiert also z.B. ein Eintrag erfolgt.

diese sub mit folgender ersetzen: die springt an, wenn das Blatt aktiviert wird. dann mußt Du nicht mehr tippen, nur einmal das Blatt weg und wieder hin wechseln.
mit nem Aktualisierungsbutton krieg ich grad nicht auf den Pinn, da will er was nicht. Kann ich aber vielleicht später nochmal versuchen, nur jetzt is grad schlecht...
Ist jetzt die Frage, was Du lieber hast.

Code:

---

Private Sub Worksheet_Activate()
    ApplicationUpdate = False
    Dim objCell As Range
    Set Target = Range("K1:K1000")
    For Each objCell In Target
        If Not Intersect(objCell, Range("K1:K1000")) Is Nothing Then
            With objCell
                Select Case .Value
                    Case 0
                        .NumberFormat = "General"
                        .Font.Name = "Arial"
                        .Font.Size = 10
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 2
                    Case 1 To 30
                        .NumberFormat = "General"
                        .Font.Name = "Arial"
                        .Font.Size = 10
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 19
                    Case 31 To 60
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1  'Schriftfarbe = weiß
                        .Interior.ColorIndex = 36  'Hintergrundfarbe = rot
                        .Font.Name = "Arial"
                    Case 61 To 90
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 6
                        .Font.Name = "Arial"
                    Case 91 To 120
                        .NumberFormat = "General"
                        .Font.ColorIndex = 1
                        .Interior.ColorIndex = 44
                        .Font.Name = "Arial"
                    Case 121 To 150
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 45
                        .Font.Name = "Arial"
                    Case 151 To 180
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 46
                        .Font.Name = "Arial"
                    Case 181 To 250
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 3
                        .Font.Name = "Arial"
                    Case 251 To 360
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 54
                        .Font.Name = "Arial"
                    Case 361 To 1000
                        .NumberFormat = "General"
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = 53
                        .Font.Name = "Arial black"
                       
                       
                    Case Else
                        .Font.ColorIndex = 11
                End Select
            End With
        End If
    Next

End Sub

---

bei mir tut's. Ich hoffe, bei Dir nu auch.

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ich Brett vorm Kopf. Habe Code bei mir rein kopiert und es funkt nicht. Könnte ich dir Datei mal per mail schicken? Wenn ja, dann schicke bitte eine mail an urlaubsanfrage@arcor.de, damit du deine nicht veröffentlichen musst.

Dicken Dank

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

hast e-mail

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Faerben.xls.txt

Bah! ;-)

nun habe ich mir solche mühe gegeben ;-) und den kompletten code
von Anfang bis Ende so gepostet - wie er ungefähr in der Entwicklung war
- und nur die Zwischenschritte 'remarkt die nichts mehr mit den Lösungscode zu tun haben
Diese Arbeit dieses zu entfernen, mute ich dem Anwender schon zu :-)

ausserdem muss in dem Macro nur an 2 Stellen Anpassungen vorgenommen werden, die Positionen wurden auch geremarkt ;-) und überhaupt -es war schon nach 22 Uhr ;-)
und das case auch XX to XXX geht - wusste ich nicht 

in Kurzform - das Makro steht in einem Modul:

Code:

---

Sub Farben()
Dim c As Range, arr, colarr, z As Byte
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) 'wertearray für überprüfung rz = arr(z)
colarr = Array(1, 3, 4, 5, 6, 7, 8, 9, 10, 11) 'hier bessere Farbwerte eintragen

    For Each c In Range("K1:K50") 'hier zeilen "Kx:Kxx") anpassen
      For z = 0 To 9 'schleife
          rz = Round(((c + 50) / 100), 0) 'Zellwert wird auf 1 Ziffer gestutzt
          If rz = arr(z) Then c.Font.ColorIndex = colarr(z) 'Farbe aus array colarr
       Next
    Next
End Sub

---

nun da es immer im Blatt aktuallisiert werden soll - Makro steht im Arbeitsblatt:

Code:

---

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range, arr, colarr, z As Byte
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
colarr = Array(1, 3, 4, 5, 6, 7, 8, 9, 10, 11) 'hier bessere Farbwerte eintragen
ApplicationUpdate = False 'Bildschirmupdate ausschalten - performace
    For Each c In Range("K1:K50") 'hier zeilen "Kx:Kxx") anpassen
      For z = 0 To 9
          rz = Round(((c + 50) / 100), 0) 'Zellwert wird auf 1 Ziffer gestutzt
          If rz = arr(z) Then c.Font.ColorIndex = colarr(z) 'Farbe aus array colarr
       Next
    Next
ApplicationUpdate = False 'Bildschirmupdate wieder einschalten
End Sub

---

Anbei Mappe (speichern mit rechte Maustaste, .txt entfernen) mit obigen Macros und dem macro Narbtabelle() von Nicole Aka Runkelrübe (wie kommt man auf diesen Nick ;-) )

Btw: Bei Usern die <10 beiträgen haben und praktisch eine komplettlösung haben wollen (da sie ja Vba kennen - aber nicht damit umgehen können) - poste ich nur den Code - [oftmals sind es Eintagsuser... - schade eigentlich]
alternativ User uppt eine Mappe - dann kann man die Änderung direkt einarbeiten und entsprechend in Textform im Forum auch was dazu sagen, was man wie und wo und weshalb geändert hat

gruss thomas - der sich manchmal wünscht, eine Glaskugel neben sich zu haben ;-)

PS: wenn in den Zellen text steht  - gibte es Error 

------------------
Am Anfang war kein Licht - und Vater blickte Kalt

[Diese Nachricht wurde von Thomas Harmening am 26. Apr. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

testneu.xls.txt

So, für den Fall, daß hier nochmal jemand drüber stolpert und tatsächlich unsere Variante in der Endfassung haben will: hier ist Sie
Mit Aktualisierung beim Öffnen und zusätzlichem Akt-button, sowie nochmal die Farbtabelle als Extra-Modul.
Gruß,
Nicole

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Schön gemacht ;-)

das was ich noch ändern würde. Zelle abfragen so das nur die mit Zahlenwerten behandelt werden (sieht doch arg unschön aus wenn die Zellen den zellrahmen verlieren ;-))

alternativ -schnell und schlampig

Code:

---

Case 0
                        .NumberFormat = "General"
                        .Font.Name = "Arial"
                        .Font.Size = 10
                        .Font.ColorIndex = 2
                        .Interior.ColorIndex = xlNone

---

grüsse thomas

------------------
Am Anfang war kein Licht - und Vater blickte Kalt
Miss Brauch

[Diese Nachricht wurde von Thomas Harmening am 27. Apr. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

nicht wahr?  bin ja Vorschlags-aufnahmebereit
das hab ich versucht mit den Rahmen, krieg es aber nicht hin 
Dein code ist der gleiche, der da schon steht.
ich hab's mal mit

Code:

---

                    Case Else
                        .Font.ColorIndex = 11
                        .Interior.ColorIndex = xlNone
                        '.Borders(xlDiagonalDown).LineStyle = xlNone
                        '.Borders(xlDiagonalUp).LineStyle = xlNone
                        '.Borders(xlEdgeLeft).LineStyle = xlNone
                        '.Borders(xlEdgeTop).LineStyle = xlNone
                        '.Borders(xlEdgeBottom).LineStyle = xlNone
                        '.Borders(xlEdgeRight).LineStyle = xlNone

---

versucht und das xlNone ausgetauscht, aber diese "hellgrauen Nicht-wirklich-Rahmen" die in einer leeren mappe zu sehen sind und nicht gedruckt werden, krieg ich nicht hin... Tips zu mir, bitte!

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

das einzige was ich noch kenne
ActiveWindow.GridlineColorIndex = 5
aber das setzt global die Farbe der Gitternetzlinien im Aktiven Blatt

- Einzige möglichkeit: Eine saubere Zelle nehmen und das format Kopieren - ist ja nur eine einmalige Aktion 

€dit, habe doch die Lösung gefunden, sieh' oben im eingefügten Codebei case 0 muss unten es so lauten
.Interior.ColorIndex = xlNone 

dann entfällt auch das Format kopieren 
------------------
Am Anfang war kein Licht - und Vater blickte Kalt
Miss Brauch

[Diese Nachricht wurde von Thomas Harmening am 27. Apr. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

jau, dat war's 
komisch, ich könnte schwören, ich hab's mal damit versucht, aber funzte nicht  war wohl doch woanders...
Dann mal noch'n schönen Tach!
Gruß,
Nicole

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP