Supportnet / Forum / Tabellenkalkulation
Makro das farbige Zellen in eine Reihenfolge sortiert
Frage
Hallo ich glaube ich habe ein etwas anspruchvolles Problem. Vielleicht kann mir da jemand helfen.
Ich habe drei Spalten bedingt formatiert. Je nach Farbkombination sollten sich die Zeilen sortieren. Dreimal rot wäre Platz 1, zweimal rot und einmal gelb wäre Platz 2. usw. Bis dreimal grün dann auf dem letzten Platz stehen würde.
In diesen Bereich auf den das Makro zugreift sollte man auch Zeilen einfügen können und das Makro sollte sich dynamisch anpassen.
Vielen Dank im Vorraus
Antwort 1 von Hajo_Zi
Hallo ??,
http://www.herber.de/bbs/texte/8colorsort.xls
Gruß Hajo
http://www.herber.de/bbs/texte/8colorsort.xls
Gruß Hajo
Antwort 2 von Hajo_Zi
Hallo ??,
mir ist jetzt erst aufgefallen das Du es mit bedingter Formatierung geacht hast. Da geht das Beispiel wohl nicht.
Die bedingte Formatierung auslesen ist das komplizierteste was mir bekannt ist.
Gruß Hajo
mir ist jetzt erst aufgefallen das Du es mit bedingter Formatierung geacht hast. Da geht das Beispiel wohl nicht.
Die bedingte Formatierung auslesen ist das komplizierteste was mir bekannt ist.
Gruß Hajo
Antwort 3 von nighty
hi all :)
auf die schnelle hab wenig zeit
daher mit hilfsspalte noch
in der die erste funktion sein sollte die dann sortiert werden koennte nach dem farbindex
gruss nighty
Function BedingungAdd(Zellen As Range) As Double
BedingungAdd = GetCellColor(Zellen)
End Function
Function GetCellColor(cell As Range) As Integer
Dim i
Dim myVal
Dim myColor As Integer
Dim done As Boolean
On Error Resume Next
Names("testname").Delete
On Error GoTo 0
Application.ReferenceStyle = xlR1C1
myVal = cell.Value
myColor = cell.Interior.ColorIndex
done = False
For i = 1 To cell.FormatConditions.Count
With cell.FormatConditions.Item(i)
If .Type = 1 Then
Select Case .Operator
Case xlBetween
If (myVal >= Evaluate(.Formula1) And myVal <= Evaluate(.Formula2)) _
Or (myVal <= Evaluate(.Formula1) And myVal >= Evaluate(.Formula2)) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlEqual
If myVal = Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlGreater
If myVal > Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlGreaterEqual
If myVal >= Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlLess
If myVal < Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlLessEqual
If myVal <= Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlNotBetween
If myVal < Evaluate(.Formula1) Or myVal > Evaluate(.Formula2) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlNotEqual
If myVal <> Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
End Select
ElseIf .Type = 2 Then
Names.Add Name:="testname", RefersToR1C1Local:=.Formula1
If Evaluate("testname") Then
myColor = .Interior.ColorIndex
done = True
End If
Names("testname").Delete
Else
MsgBox "Unbekannter Typ: " & .Type, , "PANIC: In Function GetCellColor"
Exit Function
End If
End With
If done Then Exit For
Next
Application.ReferenceStyle = xlA1
GetCellColor = myColor
End Function
auf die schnelle hab wenig zeit
daher mit hilfsspalte noch
in der die erste funktion sein sollte die dann sortiert werden koennte nach dem farbindex
gruss nighty
Function BedingungAdd(Zellen As Range) As Double
BedingungAdd = GetCellColor(Zellen)
End Function
Function GetCellColor(cell As Range) As Integer
Dim i
Dim myVal
Dim myColor As Integer
Dim done As Boolean
On Error Resume Next
Names("testname").Delete
On Error GoTo 0
Application.ReferenceStyle = xlR1C1
myVal = cell.Value
myColor = cell.Interior.ColorIndex
done = False
For i = 1 To cell.FormatConditions.Count
With cell.FormatConditions.Item(i)
If .Type = 1 Then
Select Case .Operator
Case xlBetween
If (myVal >= Evaluate(.Formula1) And myVal <= Evaluate(.Formula2)) _
Or (myVal <= Evaluate(.Formula1) And myVal >= Evaluate(.Formula2)) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlEqual
If myVal = Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlGreater
If myVal > Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlGreaterEqual
If myVal >= Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlLess
If myVal < Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlLessEqual
If myVal <= Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlNotBetween
If myVal < Evaluate(.Formula1) Or myVal > Evaluate(.Formula2) Then
myColor = .Interior.ColorIndex
done = True
End If
Case xlNotEqual
If myVal <> Evaluate(.Formula1) Then
myColor = .Interior.ColorIndex
done = True
End If
End Select
ElseIf .Type = 2 Then
Names.Add Name:="testname", RefersToR1C1Local:=.Formula1
If Evaluate("testname") Then
myColor = .Interior.ColorIndex
done = True
End If
Names("testname").Delete
Else
MsgBox "Unbekannter Typ: " & .Type, , "PANIC: In Function GetCellColor"
Exit Function
End If
End With
If done Then Exit For
Next
Application.ReferenceStyle = xlA1
GetCellColor = myColor
End Function