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 / Tabellenkalkulation

Tabellenkalkulation

Fragevon Platin7 vom 29.02.2020, 09:14 Options

Farbwert auslesen!!!

Hallo Leute!
Dieses Makro gibt den Farbwert einer Zelle aus!
Leider scheint es die Farben von bedingten Formatierungen nicht zu mögen!
Hat jemand einen Tipp, wie ich das beheben kann?

Sub Farbe2()
' Liest in den Zellen A1 bis A10 die Farnummern aus
' und schreibt sie in die Zellen B1 bis B10
For r = 3 To 15 ' Beginn der For To Next Schleife
Cells(r, 2) = Cells(r, 1).Interior.ColorIndex ' Hintergrundfarbe auslesen und schreiben
Next r ' Ende der For To Next Schleife
End Sub ' Ende des Makros

Gruss
Platin7

Antwort schreiben

Antwort 1 von Hajo_Zi vom 29.02.2020, 09:17 Options

Hallo Nick,

das ist kompliziert Link zur Datei da kommst Du wohl leichter ran, fals Du die Bedingung nachbaust.

Gruß Hajo

Antwort 2 von Platin7 vom 29.02.2020, 09:28 Options

Hallo Hajo!

Danke für den raschen Hinweis!
Aber geht es etwas weniger kompliziert!
Ich habe meine Farben in Spalte A und möchte die Werte in Spalte B!

Gruss
PLATIN7

Antwort 3 von Hajo_Zi vom 29.02.2020, 09:43 Options

Hallo Nick,

da haben sich schon einige dran versucht, falls Du eine einfachere Möglichkeit hast, lade Sie hoch.

Gruß Hajo

Antwort 4 von gast123 vom 29.02.2020, 11:13 Options

hi all :-)

fuer die bedingte form :-))

funktioniert fast immer :-)

und bedarf einer optimierung bzw korrigierung von profis

ich glaub war sogar von hajos website

gruss gast123

ein zufuegen

alt+f11/projektexplorer/allgemeines modul

nach dem ist die function unter einfuegen/function/benutzerdefiniert/BedingungAdd verfuegbar

neue formel
=BedingungAdd(bereich;farbindex)
=BedingungAdd(A1:A3;3)

Function BedingungAdd(Zellen As Range, farbe As Integer) As Double
Dim Zelle As Range
Dim farben As Integer
Application.Volatile
For Each Zelle In Zellen
farben = GetCellColor(Zelle)
If farben = farbe Then
BedingungAdd = BedingungAdd + Zelle.Value
End If
Next
End Function



Function GetCellColor(cell As Range) As IntegerDim iDim myValDim myColor As IntegerDim done As BooleanOn Error Resume NextNames("testname").DeleteOn Error GoTo 0Application.ReferenceStyle = xlR1C1myVal = cell.ValuemyColor = cell.Interior.ColorIndexdone = FalseFor i = 1 To cell.FormatConditions.CountWith cell.FormatConditions.Item(i)If .Type = 1 ThenSelect Case .OperatorCase xlBetweenIf (myVal >= Evaluate(.Formula1) And myVal <= Evaluate(.Formula2)) _Or (myVal <= Evaluate(.Formula1) And myVal >= Evaluate(.Formula2)) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlEqualIf myVal = Evaluate(.Formula1) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlGreaterIf myVal > Evaluate(.Formula1) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlGreaterEqualIf myVal >= Evaluate(.Formula1) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlLessIf myVal < Evaluate(.Formula1) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlLessEqualIf myVal <= Evaluate(.Formula1) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlNotBetweenIf myVal < Evaluate(.Formula1) Or myVal > Evaluate(.Formula2) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfCase xlNotEqualIf myVal <> Evaluate(.Formula1) ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfEnd SelectElseIf .Type = 2 ThenNames.Add Name:="testname", RefersToR1C1Local:=.Formula1If Evaluate("testname") ThenmyColor = .Interior.ColorIndexdone = TrueEnd IfNames("testname").DeleteElseMsgBox "Unbekannter Typ: " & .Type, , "PANIC: In Function GetCellColor"Exit FunctionEnd IfEnd WithIf done Then Exit ForNextApplication.ReferenceStyle = xlA1GetCellColor = myColorEnd Function

Antwort 5 von gast123 vom 29.02.2020, 11:16 Options

hi all :-))

wow was fuer eine formatierung,das 2 makro in einer zeile,das war nicht so gewollt

gruss gast123

Antwort 6 von gast123 vom 29.02.2020, 11:22 Options

hi all :-)

dann nochmal :-)

gruss gast123

Function BedingungAdd(Zellen As Range, farbe As Integer) As Double
Dim Zelle As Range
Dim farben As Integer
Application.Volatile
For Each Zelle In Zellen
farben = GetCellColor(Zelle)
If farben = farbe Then
BedingungAdd = BedingungAdd + Zelle.Value
End If
Next
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
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
End If
End With
If done Then Exit For
Next
Application.ReferenceStyle = xlA1
GetCellColor = myColor
End Function

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