Excel darabszámolás/összegzés betűszín szerint

Szeretném, ha az Excel táblázat egy cellája megadná, hogy egy általam meghatározott tartományban hány darab olyan cella van, amelyben a betűszín piros.

Sajnos, nem találtam eddig olyan képletet, amely megoldja ezt.

Szintén hasznos lenne a számomra, ha össze tudnám adni egy kiválasztott tartomány adott színű celláinak tartalmát. (pl. a pirosakat). A súgóban erre sem találtam megoldást.

Kérem segítségét!

Előre is köszönöm!

Sajnos erre a problémára nincs beépített Excel függvény. De VB kóddal megoldható.

Vesd fel a problémádat a Prog.hu-n.

Szeretném, ha az Excel táblázat egy cellája megadná, hogy egy általam meghatározott tartományban hány darab olyan cella van, amelyben a betűszín piros.

Sajnos, nem találtam eddig olyan képletet, amely megoldja ezt.

Szintén hasznos lenne a számomra, ha össze tudnám adni egy kiválasztott tartomány adott színű celláinak tartalmát. (pl. a pirosakat). A súgóban erre sem találtam megoldást.

Kérem segítségét!

Előre is köszönöm!

Sajnos erre a problémára nincs beépített Excel függvény. De VB kóddal megoldható.

Vesd fel a problémádat a Prog.hu-n.

Function SzumBetuszin(Tartomany As Range, RefBetuszin As Range) As Variant

On Error GoTo SzumBetuszin_Err

' A betűszín számoló algoritmus nem működik a tartományban

' feltételes formázással színezett betűszínekre!

Dim RefSzin As Long ' A referencia cella betűszíne

Dim xTart1 As Range ' Tartomány első része

Dim xTart2 As Range ' Tartomány második része

Dim xByt As Byte

Dim xStr As String

Dim RowStr As Long ' Row - Sorok

Dim RowEnd As Long ' Row

Dim ColStr As Long ' Column - Oszlopok

Dim ColEnd As Long ' Column

Dim xRow As Long ' Row

Dim xCol As Long ' Column

Dim xSum As Long ' Összegzés

If InStr(1, RefBetuszin.Address, ":", vbBinaryCompare) > 0 Then

SzumBetuszin = "#A RefBetűszín nem lehet tartomány!"

Exit Function

End If

RefSzin = Cells(RefBetuszin.Row, RefBetuszin.Column).Font.Color

xStr = Tartomany.Address

xStr = Replace(xStr, "$", "", 1, , vbBinaryCompare)

xByt = InStr(1, xStr, ":", vbBinaryCompare)

If xByt = 0 Then

' Egy cella

RowStr = Range(xStr).Row

RowEnd = RowStr

ColStr = Range(xStr).Column

ColEnd = RowStr

Else

' Tartomány

Set xTart1 = Range(Left(xStr, xByt - 1))

Set xTart2 = Range(Right(xStr, Len(xStr) - xByt))

RowStr = xTart1.Row

RowEnd = xTart2.Row

ColStr = xTart1.Column

ColEnd = xTart2.Column

End If

xSum = 0

For xCol = ColStr To ColEnd ' Oszlopok

For xRow = RowStr To RowEnd ' Sorok

If RefSzin = Cells(xRow, xCol).Font.Color Then xSum = xSum + 1

Next xRow

Next xCol

SzumBetuszin = xSum

Exit Function

'------------------------------------------------------------------------------

SzumBetuszin_Err:

MsgBox "#" & Err.Number & vbCrLf & _

Err.Description, vbCritical, "Function SzumBetuszin(Tartomany As Range, RefBetuszin As Range) As Variant"

End Function