Tipps & Tricks
13.05.2003, 05:00 Uhr
Farben zählen in Excel III
Eure Makros zum Farben zählen finde ich nun wirklich praktisch. Jedoch habe ich noch eine besondere Anwendungsweise und bekomme das leider nur umständlich hin. Jedes Tabellenblatt benutze ich für ein eigenes Projekt. Die Tabellenblätter haben eigentlich nix miteinander zu tun, sehen jedoch alle gleich aus. In diesen Blättern befinden sich Zellenbereiche (immer dieselben), in denen ich Farben Zählen möchte. Zur Zeit schreibe ich also Ihr Makro für jedes Tabellenblatt um, um die Ergebnisse einzeln für Jedes Blatt auf jedem Blatt zu erhalten und nicht das Ergebnis aller Blätter zusammen. Bei 20 Tabellenblättern und mehr wird das etwas lästig. Könnt Ihr mir bei einer eleganteren Lösung helfen?
Das bestehende Makro, welches die Farben in allen Tabellenblätter zählt und summiert [1] kann leicht angepasst werden um dies zu erreichen. Das Ende der Schleife (loop) wird nach unten verschoben, damit Ausgabe in jedem Tabellenblatt einzeln erfolgt. Ausserdem müssen die Variablen innerhalb der Schleife wieder auf 0 gesetzt werden, bevor neu gezählt wird.
---------------------------------------------------
Makro zum Kopieren:
---------------------------------------------------
Sub FarbenzaehlenAlleTabsEinzeln()
Dim Zelle As Object
Dim SA, SB As Integer
Dim rot%, gelb%, gruen%
'Blätter-Bereich angeben:
SA = 1 'Erstes Blatt
SB = 6 'Letztes Blatt
Application.ScreenUpdating = False
'Blätter und Zellen durchsuchen
Do Until SA > SB
Sheets(SA).Select
'Bereich markieren
[A4:z20].Select
'Variablen auf 0 setzen
rot = 0: gelb = 0: gruen = 0
'zählen
For Each Zelle In Selection
If Zelle.Interior.ColorIndex = 3 Then rot = rot + 1
If Zelle.Interior.ColorIndex = 6 Then gelb = gelb + 1
If Zelle.Interior.ColorIndex = 4 Then gruen = gruen + 1
Next
'Rückgabe der Variablen
[a1].Select
ActiveCell.Formula = rot
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = gelb
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = gruen
ActiveCell.Offset(0, -2).Select
SA = SA + 1
Loop
SA = SA - SB
Sheets(SA).Select
Application.ScreenUpdating = True
End Sub
---------------------------------------------------
Kommentare
Es sind keine Kommentare vorhanden.
