Group Highlighting

[Dorian C. Chalom]

I have a spreadsheet of

123
123
123
456
456
456
789
234
234
234

I want 123 to be shaded one color
456 another color
and 234 the same color of 123
and go on that way
hieghtlighting the group of records alternatiing colors
How might I go about doing this?

Thank you...

 

[Heera]

sub ColoursM()

Range ("A1").select

Do until activecell.value =""
if activecell.value = 123 or 234 then
activecell.Interior.ColorIndex = 25
else if
activecell.value = 456 then
activecell.interior.colorIndex=45
End if
activecell.offset(1,0).select
loop

End Sub

 

[Mike H]

Hi,

I assume column A. Right click your sheet tab, view code and paste this in
and run it


Sub prime_Lending()
icolour = 3
Range("A1").Interior.ColorIndex = icolour
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A2:A" & lastrow)
For Each c In myrange
If c.Value = c.Offset(-1).Value Then
c.Interior.ColorIndex = icolour
Else
If c.Offset(-1).Interior.ColorIndex = 3 Then
icolour = 6
Else
icolour = 3
End If
c.Interior.ColorIndex = icolour
End If
Next
End Sub

Mike

 

[Dorian C. Chalom]

Beutiful!
Very close to what I need and I am sure it will work.
The only thing I think may be missing is there may not be a repeat of a
code....
456
456
456
789
234
234
234

789 is not a repeating number and so I want that untouched.
And I want to do the complete row not just the cell....

Thanks a bunch!

 

[Mike H]

Hi,

It's always a good idea to ask the question you want the answer to in the
first place

try this to leave singletons uncoloured

Sub prime_Lending()
icolour = 3
Range("A1").Interior.ColorIndex = icolour
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A2:A" & lastrow)
For Each c In myrange
If c.Value = c.Offset(-1).Value Then
c.Interior.ColorIndex = icolour
ElseIf c.Value <> c.Offset(-1).Value And c.Value <> c.Offset(1).Value Then

Else
If c.Offset(-1).Interior.ColorIndex = 3 Then
icolour = 6
Else
icolour = 3
End If
c.Interior.ColorIndex = icolour
End If
Next
End Sub

Mike

 

[Mike H]

oops,

Missed the entirerow bit

Sub prime_Lending()
icolour = 3
Range("A1").EntireRow.Interior.ColorIndex = icolour
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A2:A" & lastrow)
For Each c In myrange
If c.Value = c.Offset(-1).Value Then
c.EntireRow.Interior.ColorIndex = icolour
ElseIf c.Value <> c.Offset(-1).Value And c.Value <> c.Offset(1).Value Then

Else
If c.Offset(-1).Interior.ColorIndex = 3 Then
icolour = 6
Else
icolour = 3
End If
c.EntireRow.Interior.ColorIndex = icolour
End If
Next
End Sub

Mike

 

[AndrewCerritos]

Here is my take:
1) data in col.A, at least two rows, start at row.1
2) shade any contiguous rows with same data
3) singleton: no color
4) alternate color

Private Sub AlternateColor()
Dim celX As Range
Const ColorIndex_ONE = 20
Const ColorIndex_TWO = 40
Dim iFLG As Integer
Dim idxColor As Long

idxColor = ColorIndex_ONE
iFLG = 0
Set celX = ActiveSheet.[A2]
Do While celX.Value <> ""
If celX.Value = celX.Offset(-1, 0).Value Then
iFLG = iFLG + 1
celX.EntireRow.Interior.ColorIndex = idxColor
If iFLG = 1 Then
celX.Offset(-1, 0).EntireRow.Interior.ColorIndex = idxColor
End If
Else
If iFLG > 0 Then
If idxColor = ColorIndex_ONE Then
idxColor = ColorIndex_TWO
Else
idxColor = ColorIndex_ONE
End If
iFLG = 0
End If
End If
Set celX = celX.Offset(1, 0) ' next cell
Loop
End Sub

--AC

 

[Dorian C. Chalom]

Perfect...now that is everything!

oops,

Missed the entirerow bit

Sub prime_Lending()
icolour = 3
Range("A1").EntireRow.Interior.ColorIndex = icolour
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A2:A" & lastrow)
For Each c In myrange
If c.Value = c.Offset(-1).Value Then
c.EntireRow.Interior.ColorIndex = icolour
ElseIf c.Value <> c.Offset(-1).Value And c.Value <> c.Offset(1).Value
Then

Else
If c.Offset(-1).Interior.ColorIndex = 3 Then
icolour = 6
Else
icolour = 3
End If
c.EntireRow.Interior.ColorIndex = icolour
End If
Next
End Sub

Mike

 

[Dorian C. Chalom]

Mike;

Thanks!
That worked perfectly.
Just what I wanted...