Hi, This code counts the number of coloured cells in each column, and then colours th first cell in that column with the same colour as the largest number.
There must be a value below or in the last coloured cell of ec column or the code will miss the cell.
You can change the selection to an explicit range if you require.
Columns are checked up to the last value in row (1).
Dim Rng As Range, Dn As Range, Col As Integer, Colour As Integer
Dim Last As Integer, Red, Yellow, Green, Blue
Dim ray, oNam As Integer, ray2
Const R = 3
Const Y = 6
Const G = 4
Const B = 5
Last = Cells(1, Columns.Count).End(xlToLeft).Column
For Col = 1 To Last
Set Rng = Range(Cells(2, Col), Cells(Rows.Count, Col).End(xlUp))
For Each Dn In Rng
Select Case Dn.Interior.ColorIndex
Case 3: Red = Red + 1
Case 6: Yellow = Yellow + 1
Case 4: Green = Green + 1
Case 5: Blue = Blue + 1
End Select
Next Dn
ray = Array(Red, Yellow, Green, Blue)
ray2 = Array(R, Y, G, B)
Colour = WorksheetFunction.Max(ray)
For oNam = 0 To UBound(ray)
If ray(oNam) = Colour And Colour > 0 Then
Cells(1, Col).Interior.ColorIndex = ray2(oNam)
Exit For
End If
Next oNam
Colour = 0: Red = 0: Yellow = 0: Green = 0: Blue = 0
Next Col
Regards Mick
Bookmarks