MrGee
25.06.10,16:31
Zdravím vás;
Už dlhšie hľadám na nete vzorec, ktorý by vedel zrátať bunky, ktoré obsahujú text s určitou farbou. Nemyslím ale sumu buniek(SUM), ale počet buniek(COUNT).
Našiel som už vzorec ktorý to zvládol, ale počíta aj naformátované bunky, v ktorých nieje napísané nič, ale predsa majú definovanú farbu textu.
Modul vzorca vyzerá takto:
Function CountColor(InRange As Range, ColorIndex As Long, _
Optional OfText As Boolean = False) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''
' CountColor
' This function counts the cells in InRange whose ColorIndex
' is equal to the ColorIndex parameter. The ColorIndex of the
' Font is tested if OfText is True, or the Interior property
' if OfText is omitted or False. If ColorIndex is not a valid
' ColorIndex (1 -> 56, xlColorIndexNone, xlColorIndexAutomatic)
' 0 is returned. If ColorIndex is 0, then xlColorIndexNone is
' used if OfText is Fasle or xlColorIndexAutomatic if OfText
' is True. This allows the caller to use a value of 0 to indicate
' no color for either the Interior or the Font.
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''
Dim R As Range
Dim N As Long
Dim CI As Long
If ColorIndex = 0 Then
If OfText = False Then
CI = xlColorIndexNone
Else
CI = xlColorIndexAutomatic
End If
Else
CI = ColorIndex
End If
Application.Volatile True
Select Case ColorIndex
Case 0, xlColorIndexNone, xlColorIndexAutomatic
' OK
Case Else
If IsValidColorIndex(ColorIndex) = False Then
CountColor = 0
Exit Function
End If
End Select
For Each R In InRange.Cells
If OfText = True Then
If R.Font.ColorIndex = CI Then
N = N + 1
End If
Else
If R.Interior.ColorIndex = CI Then
N = N + 1
End If
End If
Next R
CountColor = N
End Function
Možno by to šlo aj cez funkciu COUNTA, ale zas treba nejaký ďalší vzorec navyše...
Prosím poraďte
Už dlhšie hľadám na nete vzorec, ktorý by vedel zrátať bunky, ktoré obsahujú text s určitou farbou. Nemyslím ale sumu buniek(SUM), ale počet buniek(COUNT).
Našiel som už vzorec ktorý to zvládol, ale počíta aj naformátované bunky, v ktorých nieje napísané nič, ale predsa majú definovanú farbu textu.
Modul vzorca vyzerá takto:
Function CountColor(InRange As Range, ColorIndex As Long, _
Optional OfText As Boolean = False) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''
' CountColor
' This function counts the cells in InRange whose ColorIndex
' is equal to the ColorIndex parameter. The ColorIndex of the
' Font is tested if OfText is True, or the Interior property
' if OfText is omitted or False. If ColorIndex is not a valid
' ColorIndex (1 -> 56, xlColorIndexNone, xlColorIndexAutomatic)
' 0 is returned. If ColorIndex is 0, then xlColorIndexNone is
' used if OfText is Fasle or xlColorIndexAutomatic if OfText
' is True. This allows the caller to use a value of 0 to indicate
' no color for either the Interior or the Font.
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''
Dim R As Range
Dim N As Long
Dim CI As Long
If ColorIndex = 0 Then
If OfText = False Then
CI = xlColorIndexNone
Else
CI = xlColorIndexAutomatic
End If
Else
CI = ColorIndex
End If
Application.Volatile True
Select Case ColorIndex
Case 0, xlColorIndexNone, xlColorIndexAutomatic
' OK
Case Else
If IsValidColorIndex(ColorIndex) = False Then
CountColor = 0
Exit Function
End If
End Select
For Each R In InRange.Cells
If OfText = True Then
If R.Font.ColorIndex = CI Then
N = N + 1
End If
Else
If R.Interior.ColorIndex = CI Then
N = N + 1
End If
End If
Next R
CountColor = N
End Function
Možno by to šlo aj cez funkciu COUNTA, ale zas treba nejaký ďalší vzorec navyše...
Prosím poraďte
MrGee
26.06.10,08:00
Po dlhom dni hľadania, snorenia a vypytovania sa na fórach od výmyslu sveta, som sa dopracoval k odpovedi:)
For Each r In InRange.Cells
If OfText = True Then
If r.Font.ColorIndex = CI And r.Value <> "" Then
N = N + 1
End If
Else
If r.Interior.ColorIndex = CI And r.Value <> "" Then
N = N + 1
End If
End If
Next r
For Each r In InRange.Cells
If OfText = True Then
If r.Font.ColorIndex = CI And r.Value <> "" Then
N = N + 1
End If
Else
If r.Interior.ColorIndex = CI And r.Value <> "" Then
N = N + 1
End If
End If
Next r
Kabaka123
02.04.15,17:06
posúvam.... pre mňa geniálny objav... súčet buniek a počet buniek podľa farby už aj v exceli 2003 s nástrojom Rj tools... od Radeka Jurečka geniálna vec...
http://www.rjurecek.cz/excel/rj-tools/
http://www.rjurecek.cz/excel/rj-tools/
Chobot
02.04.15,19:51
To koľkokrát tu chceš pridať túto reklamu?
Kabaka123
03.04.15,05:22
už stačilo...:)