- Sub ko****je()
- Dim lRow As Long
- Dim iCntr As Long
- Dim boje(56)
- lRow = ActiveSheet.UsedRange.Rows.Count
- For iCntr = lRow To 1 Step -1
- boje(ColorIndex(Cells(iCntr, 1))) = boje(ColorIndex(Cells(iCntr, 1))) + 1
- Next iCntr
- Dim txt As String
- For iCntr = 0 To 56
- If boje(iCntr) > 0 Then txt = txt & CStr(iCntr) & vbNewLine
- Next iCntr
- MsgBox txt
- End Sub
- '---------------------------------------------------------------------
- ' ColorIndex Function
- '---------------------------------------------------------------------
- ' Function: Returns the colorindex of the supplied range
- ' Synopsis: Initially, gets a colorindex value for black and white
- ' from the activeworkbook colour palette
- ' Then works through each cell in the supplied range and
- ' determines the colorindex, and adds to array
- ' Finishes by returning acumulated array
- ' Variations: Determines cell colour (interior) or text colour (font)
- ' Default is cell colour
- ' Constraints: Does not count colours set by conditional formatting
- '---------------------------------------------------------------------
- ' Author: Bob Phillips
- ' Additions for ranges suggested by Harlan Grove
- '---------------------------------------------------------------------
- '---------------------------------------------------------------------
- Function ColorIndex(Rng As Range, _
- Optional text As Boolean = False) As Variant
- '---------------------------------------------------------------------
- Dim cell As Range, row As Range
- Dim i As Long, j As Long
- Dim iWhite As Long, iBlack As Long
- Dim aryColours As Variant
- If Rng.Areas.Count > 1 Then
- ColorIndex = CVErr(xlErrValue)
- Exit Function
- End If
- iWhite = WhiteColorindex(Rng.Worksheet.Parent)
- iBlack = BlackColorindex(Rng.Worksheet.Parent)
- If Rng.Cells.Count = 1 Then
- If text Then
- aryColours = DecodeColorIndex(Rng, True, iBlack)
- Else
- aryColours = DecodeColorIndex(Rng, False, iWhite)
- End If
- Else
- aryColours = Rng.Value
- i = 0
- For Each row In Rng.Rows
- i = i + 1
- j = 0
- For Each cell In row.Cells
- j = j + 1
- If text Then
- aryColours(i, j) = _
- DecodeColorIndex(cell, True, iBlack)
- Else
- aryColours(i, j) = _
- DecodeColorIndex(cell, False, iWhite)
- End If
- Next cell
- Next row
- End If
- ColorIndex = aryColours
- End Function
- '---------------------------------------------------------------------
- Private Function WhiteColorindex(oWB As Workbook)
- '---------------------------------------------------------------------
- Dim iPalette As Long
- WhiteColorindex = 0
- For iPalette = 1 To 56
- If oWB.Colors(iPalette) = &HFFFFFF Then
- WhiteColorindex = iPalette
- Exit Function
- End If
- Next iPalette
- End Function
- '---------------------------------------------------------------------
- Private Function BlackColorindex(oWB As Workbook)
- '---------------------------------------------------------------------
- Dim iPalette As Long
- BlackColorindex = 0
- For iPalette = 1 To 56
- If oWB.Colors(iPalette) = &H0 Then
- BlackColorindex = iPalette
- Exit Function
- End If
- Next iPalette
- End Function
- '---------------------------------------------------------------------
- Private Function DecodeColorIndex(Rng As Range, _
- text As Boolean, _
- idx As Long)
- '---------------------------------------------------------------------
- Dim iColor As Long
- If text Then
- iColor = Rng.Font.ColorIndex
- Else
- iColor = Rng.Interior.ColorIndex
- End If
- If iColor < 0 Then
- iColor = idx
- End If
- DecodeColorIndex = iColor
- End Function
- '---------------------------------------------------------------------
- ' End of ColorIndex Function
- '---------------------------------------------------------------------