Sub Colour_groups()
'Andrew Cave andrew.cave.blogging at gmail 2014
'**colors a spreadsheet row according to whether the PREVIOUS cell in the activecell column
' matches it or not
'** if no match colors the cell to a different colour.
'**Gets width of colour block from rightmost cell in Row 1
Dim i As Long
Dim rg As Range
Dim c As Range, lastCell As Range
Dim rg2 As Range
Dim row As Long
Dim rowChange As Range
Dim groupCount As Long
Dim col As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim strActiveColumn As String
Dim intActiveColumn As Long
Dim darkColour As Long
Dim darkColour2 As Long
Dim lightColour As Long
Dim prevValue As Variant
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
'51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
'52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
'50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
'56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
col = ws.Range(IIf(wb.FileFormat = 56, "iv1", "xfd1")).End(xlToLeft).Column 'rightmost cell on the sheet - move left to find edge of data
intActiveColumn = ActiveCell.Column
'build the column letter names up
i = Int(Log(intActiveColumn) / Log(26)) 'get log base 26 (so we know how long the column name will be
'get the string name of the column (A,B...AB...IV etc)
Do
If i > 0 Then
strActiveColumn = strActiveColumn & Chr(intActiveColumn \ (26 ^ i) + 64)
Else
strActiveColumn = strActiveColumn & Chr(intActiveColumn + 64)
End If
intActiveColumn = intActiveColumn Mod (26 ^ i)
i = i - 1
Loop While i >= 0
' reset values
i = 0
intActiveColumn = ActiveCell.Column
row = ws.Cells(IIf(wb.FileFormat = 56, 65536, 2 ^ 20), ActiveCell.Column).End(xlUp).row
row = ws.Cells(IIf(wb.FileFormat = 56, 65536, 2 ^ 20), ActiveCell.Column).End(xlUp).row
darkColour = 35
darkColour2 = 44
lightColour = 0
Set rg = ws.Range(strActiveColumn & "2:" & strActiveColumn & row)
Set rowChange = rg.Cells(1, 1)
For Each c In rg
If c.Value = rowChange.Value Then 'are we in a group?
groupCount = groupCount + 1 'count rows in group
Else
'and blank the current row
If i Mod 3 = 0 Then
Range(c.Offset(0 - groupCount, 1 - intActiveColumn), c.Offset(-1, col - intActiveColumn)).Interior.ColorIndex = darkColour
ElseIf i Mod 3 = 1 Then
Range(c.Offset(0 - groupCount, 1 - intActiveColumn), c.Offset(-1, col - intActiveColumn)).Interior.ColorIndex = darkColour2
Else
Range(c.Offset(0 - groupCount, 1 - intActiveColumn), c.Offset(-1, col - intActiveColumn)).Interior.ColorIndex = lightColour
End If
i = i + 1
groupCount = 1
Set rowChange = c ' keep a reference to the (potential) first row of the group
End If
Set lastCell = c
Next c
If groupCount > 1 Then 'handle the last row being part of a group
If i Mod 3 = 0 Then
Range(lastCell.Offset(1 - groupCount, 1 - intActiveColumn), lastCell.Offset(0, col - intActiveColumn)).Interior.ColorIndex = darkColour
ElseIf i Mod 3 = 1 Then
Range(lastCell.Offset(1 - groupCount, 1 - intActiveColumn), lastCell.Offset(0, col - intActiveColumn)).Interior.ColorIndex = darkColour2
Else
Range(lastCell.Offset(1 - groupCount, 1 - intActiveColumn), lastCell.Offset(0, col - intActiveColumn)).Interior.ColorIndex = lightColour
End If
Else 'colour the last row if it is not in a group
Range(Cells(lastCell.row, 1), Cells(lastCell.row, col)).Interior.ColorIndex = IIf(i Mod 3 = 0, darkColour, IIf(i Mod 3 = 1, darkColour2, lightColour))
End If
'handle the end of the lists -- ie if last one is a duplicate
Set ws = Nothing: Set wb = Nothing
End Sub
