2007: In Tabelle nach Farbe filtern, Ergebnis wegschreiben

16/03/2009 - 14:10 von stefan schneider | Report spam
Hallo,

ich möchte unter 2007 eine Tabelle nach Farben filtern und dann die über
die Ergebniszeile erhaltene Summe jeder Farbe in bestimmte Zellen schreiben.

Ich habe mir folgenden Code aufgezeichnet:


ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1,
Criteria1:= _
RGB(255, 255, 0), Operator:=xlFilterCellColor


ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1,
Criteria1:= _
RGB(55, 96, 145), Operator:=xlFilterCellColor


ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1,
Criteria1:= _
RGB(255, 0, 0), Operator:=xlFilterCellColor


ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1,
Criteria1:= _
RGB(192, 0, 0), Operator:=xlFilterCellColor


ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1,
Criteria1:= _
RGB(228, 109, 10), Operator:=xlFilterCellColor


Sowie für die Ergebnisse:
Range("A21").FormulaR1C1 = "=Tabelle1[[#Totals],[12.03.2009]]"

Wie kann ich es programmieren, dass nach Farbe 1 gefiltert wird, dass
Ergebnis in A21 eingetragen,dann nach Farbe 2 dass Ergebniss in b21
eingetragen, etc.

Kann da jemand helfen?

Danke Stefan
 

Lesen sie die antworten

#1 Melanie Breden
16/03/2009 - 17:10 | Warnen spam
Hallo Stefan,

"stefan schneider" schrieb:
ich möchte unter 2007 eine Tabelle nach Farben filtern und dann die über
die Ergebniszeile erhaltene Summe jeder Farbe in bestimmte Zellen schreiben.

Ich habe mir folgenden Code aufgezeichnet:

ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=1,
Criteria1:= _
RGB(255, 255, 0), Operator:=xlFilterCellColor

Sowie für die Ergebnisse:
Range("A21").FormulaR1C1 = "=Tabelle1[[#Totals],[12.03.2009]]"

Wie kann ich es programmieren, dass nach Farbe 1 gefiltert wird, dass
Ergebnis in A21 eingetragen,dann nach Farbe 2 dass Ergebniss in b21
eingetragen, etc.



Ich denke, dass man zuerst die Farben aus der Tabelle auslesen muss, dann
in RGB umwandeln, filtern und schließlich die Ergebnisse in Zellen schreiben.

Wie funktioniert folgende Prozedur bei dir?:

Public Sub FarbenFiltern()
Dim Lst As ListObject
Dim colC As New Collection
Dim rngCell As Range
Dim lngRow As Long
Dim i As Long

' Zielzeile
lngRow = 21

Application.ScreenUpdating = False
With ActiveSheet
Set Lst = .ListObjects("Tabelle1")

' Verwendete Farben auslesen
On Error Resume Next
For Each rngCell In Lst.ListColumns(1).DataBodyRange
colC.Add rngCell.Interior.Color, "MB" & rngCell.Interior.Color
Next rngCell
On Error GoTo 0

For i = 1 To colC.Count
' Liste nach Farben filtern
Lst.Range.AutoFilter Field:=1, Operator:=xlFilterCellColor, Criteria1:= _
RGB(GetRGB(colC(i), "R"), GetRGB(colC(i), "G"), GetRGB(colC(i), "B"))

' Farbe an Summenzelle zuweisen
.Cells(lngRow, i).Interior.Color = _
RGB(GetRGB(colC(i), "R"), GetRGB(colC(i), "G"), GetRGB(colC(i), "B"))

' Ergebnis nicht nach fester Überschrift, sondern Spalte berechnen
.Cells(lngRow, i).Value = Evaluate("=SUBTOTAL(109," & Lst.ListColumns(1).DataBodyRange.Address & ")")
Next i

' Filter zurücksetzen
Lst.Range.AutoFilter Field:=1
End With
Application.ScreenUpdating = True
End Sub

Public Function GetRGB(ByVal lngColor As Long, strFarbe As String) As Long
Select Case strFarbe
Case "R": GetRGB = (lngColor And &HFF&)
Case "G": GetRGB = (lngColor And &HFF00&) \ 256
Case "B": GetRGB = (lngColor And &HFF0000) \ 65536
End Select
End Function


Mit freundlichen Grüssen
Melanie Breden

- Microsoft MVP für Excel -
www.melanie-breden.de

Ribbon-Programmierung für Office 2007 http://tinyurl.com/59awla

Ähnliche fragen