conditional formats, match or index

[Anthon]

Can the following be done? Match Column B, find the same names, colour the
cell in a certain colour, find the next match and make it a different colour
etc etc. The column needs to remain in the same order as below.

Thanks
Anthon

A B
1 JOHN
2 TIM
3 JOHN
4 ANDY
5 JILL
6 JEREMY
7 TIM
8 KEITH
9 MARK
10 ANDY
11 ROBERT
12 JILL
13 MARK
14 JIM
15 ROBERT
16 KEITH
17 KIM
18 DANK
20 KEITH

 

[Bernie Deitrick]

Anthon,

How many repeats can you have? Does the first occurence of JOHN need to be a
different color from the first occurence of TIM?

And would a macro be an acceptable solution?

Bernie
MS Excel MVP

 

[Pete_UK]

If you are using XL2003 or earlier you are limited to 3 conditional
formats in a cell, so some names will have to use the same colour.

One way of setting this up is to enter these values/formulae in the
cells stated:

C1: 1
D1: 1
C2: =COUNTIF(B$1:B2,B2)
D2: =IF(C2=1,COUNTIF(C$1:C2,1),INDEX(D$11,MATCH(B2,B$1:B2,0)))

Copy C22 down the columns as required.

Then highlight cells B1:B19 with B1 as the active cell, and click on
Format | Conditional Format. Choose Formula Is rather than Cell Value
Is in the first box, and enter this formula:

=MOD(D1,3)=1

Click on the Format button, then the Patterns tab (for background
colour) and choose a colour (eg Bright Yellow). Click OK, then click
Add to set up the second condition. Again choose Formula Is, and enter
this formula:

=MOD(D1,3)=2

Click on the Format button again, then the Patterns tab and choose a
colour for this second condition (eg Lime). Click OK, then click Add
to set up the third condition. Again choose Formula Is, and enter this
formula:

=MOD(D1,3)=0

Click on the Format button again, then the Patterns tab and choose a
colour for this third condition (eg Turquoise). Click OK twice to exit
the CF dialogue box.

You should now see those names on a coloured background: John, Jill,
Mark and Kim will all appear bright yellow; Tim, Jeremy, Robert and
Dank will appear Lime, and Andy, Keith and Jim will appear Turquoise.

I think this is what you wanted - you can hide columns C and D if you
don't want to see them.

Hope this helps.

Pete

 

[Anthon]

Hi, thanks Pete, what i forgot to mention was, that i have allready used up
the 3 conditional formats for other checks in that B column, want to know if
there is another way of doing this.

Regards
Anthon

 

[Anthon]

Hi Bernie, thank you for response. Sometimes i have up to five different
repeats of a name, and yes, the colours should be different.

And if it can be done with a macro, then yes it is acceptable.

Also, i forgot to mention that I have already used up my 3 conditional
formats for this B column for checking other conditions in this column.

Regards
Anthon

 

[Pete_UK]

Well. that's a big thing to forget to mention !!

You will have to use a macro to get more colours - perhaps Bernie will
come up with one.

Pete

 

[Sandy Mann]

Bernie will probably be along in a minute with better, more efficient code
but this VBA code done for the exercise works for names in Column B:

Option Explicit
Sub ColourIt()
Dim LastRow As Long
Dim cIndex As Integer
Dim Flag As Boolean
Dim cCount As Long

LastRow = Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

Columns("C:C").Insert Shift:=xlToRight
Range("C1").Value = 1
Range(Cells(1, 3), Cells(LastRow, 3)) _
.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Flag = False
cIndex = 3

For cCount = 1 To LastRow
If Cells(cCount, 2).Value = Cells(cCount + 1, 2).Value Then
With Range(Cells(cCount, 2), Cells(cCount + 1, 2)).Interior
.ColorIndex = cIndex
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
cIndex = cIndex + 1
Next cCount

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Columns("C:C").Delete Shift:=xlToLeft

Range("B1").Select

Application.ScreenUpdating = True

End Sub



--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

 

[Bernie Deitrick]

Sandy,

Your code works very well, so I'll take a pass on trying to do my own version.

Bernie
MS Excel MVP

 

[Sandy Mann]

Sandy,

Your code works very well, so I'll take a pass on trying to do my own
version.

No it doesn't! I wrote half of it last night and then when I saw that it
still hadn't been finally answered this morning I quickly finished it off
and posted it. After posting I noticed that I had left a line in that I had
intended to change because it changed the Color Index at each Successful IF
instead of the Unsuccessful ones but I have not been able to get back on
line until now. How frustrating!!!!

Anyway here is the corrected code:

Option Explicit
Sub ColourIt()
Dim LastRow As Long
Dim cIndex As Integer
Dim Flag As Boolean
Dim cCount As Long

LastRow = Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

Columns("C:C").Insert Shift:=xlToRight
Range("C1").Value = 1
Range(Cells(1, 3), Cells(LastRow, 3)) _
.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Flag = False
cIndex = 3

For cCount = 1 To LastRow
If Cells(cCount, 2).Value = Cells(cCount + 1, 2).Value Then
With Range(Cells(cCount, 2), Cells(cCount + 1, 2)).Interior
.ColorIndex = cIndex
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Flag = True
End If
If Cells(cCount, 2).Value <> Cells(cCount + 1, 2).Value _
And Flag = True Then cIndex = cIndex + 1
Next cCount

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Columns("C:C").Delete Shift:=xlToLeft

Range("B1").Select

Application.ScreenUpdating = True

End Sub

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

 

[Sandy Mann]

Well that works for the OP's data but if there is more than one non-matching
cell then the Color Index will be indexed up each time. It still gave
different colours but if there were enough non-matching cells it is possible
that we could run out of colours. It would therefore be better to use this
code:

Option Explicit
Sub ColourIt()
Dim LastRow As Long
Dim cIndex As Integer
Dim Flag As Boolean
Dim cCount As Long

LastRow = Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

Columns("C:C").Insert Shift:=xlToRight
Range("C1").Value = 1
Range(Cells(1, 3), Cells(LastRow, 3)) _
.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Flag = False
cIndex = 3

For cCount = 1 To LastRow
If Cells(cCount, 2).Value = Cells(cCount + 1, 2).Value Then
With Range(Cells(cCount, 2), Cells(cCount + 1, 2)).Interior
.ColorIndex = cIndex
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Flag = True
End If
If Cells(cCount, 2).Value <> Cells(cCount + 1, 2).Value _
And Flag = True Then
cIndex = cIndex + 1
Flag = False
End If
Next cCount

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Columns("C:C").Delete Shift:=xlToLeft

Range("B1").Select

Application.ScreenUpdating = True

End Sub

It's just so wonderful to be able to post again! <g>


--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

 

[Anthon]

Hi. I get a 'type mismatch' error at this line : If Cells(cCount, 2).Value =
Cells(cCount + 1, 2).Value Then

Regards
Anthon

 

[Anthon]

Hi. found the reason for the mis-match error, sometimes when I do a web
query, some names come up as #NA as there are not always 20 names. How do I
change the code to ignore the #NA's and also what code can I use to undo the
macro for the next set of data, e.g macro1 would be to colourit and macro2
can reset the colours for the next query.

Regards
Anthon

 

[Sandy Mann]

Hi Anthon,

I can't see any reason for your getting the error in that line and I copied
the line from the post and pasted it into the code and it ran just fine.

Did you copy the code from the post and paste it into the module or did you
transcribe it?

If you want, I can send you the workbook that I wrote it in for you to have
a look at. If that is what you want then send me a email by correcting the
address in my signature by replacing the part after the @ sign as it says.
If you just click on the "Reply" button it will end up in a spam trap.

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

 

[Sandy Mann]

This works for me.

Note that I also enclosed the comparison cells in a Ucase function to make
it ignore different cases. If you don't want that then just remove it


Option Explicit
Sub ColourIt()
Dim LastRow As Long
Dim cIndex As Integer
Dim Flag As Boolean
Dim cCount As Long
Dim acIndex(1 To 10) As Variant
Dim x As Integer

For x = 1 To 10
Select Case x

Case 1 To 6
acIndex(x) = x

Case 7 To 10
acIndex(x) = x + 36
End Select
Next x

LastRow = Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

Columns("C:C").Insert Shift:=xlToRight
Range("C1").Value = 1
Range(Cells(1, 3), Cells(LastRow, 3)) _
.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Flag = False
cIndex = 3
For cCount = 1 To LastRow
If WorksheetFunction.IsNA(Cells(cCount, 2).Value) Or _
WorksheetFunction.IsNA(Cells(cCount + 1, 2).Value) _
Then GoTo SkipIt

If UCase(Cells(cCount, 2).Value) = _
UCase(Cells(cCount + 1, 2).Value) Then
With Range(Cells(cCount, 2), Cells(cCount + 1, 2)).Interior
.ColorIndex = acIndex(cIndex)
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Flag = True
End If
If Cells(cCount, 2).Value <> Cells(cCount + 1, 2).Value _
And Flag = True Then
cIndex = cIndex + 1
Flag = False
End If
SkipIt:

Next cCount
On Error GoTo 0

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Columns("C:C").Delete Shift:=xlToLeft

Range("B1").Select

Application.ScreenUpdating = True

End Sub

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

 

[Sandy Mann]

Hi Anthon,
I see that I posted code from an experimental W/B that I was working on in
anticipation of your saying that some of the colours were quite dark and it
only has 10 colours. Here is a version that has 25 colours:

Option Explicit
Sub ColourIt()
Dim LastRow As Long
Dim cIndex As Integer
Dim Flag As Boolean
Dim cCount As Long
Dim acIndex As Variant
Dim x As Integer

acIndex = Array(3, 4, 5, 6, 7, _
8, 15, 17, 20, 22, 24, 36, 37, _
38, 39, 40, 41, 42, 43, 44, 45, 46, _
48, 50, 34)

LastRow = Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

Columns("C:C").Insert Shift:=xlToRight
Range("C1").Value = 1
Range(Cells(1, 3), Cells(LastRow, 3)) _
.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("B1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Flag = False
cIndex = 3
For cCount = 1 To LastRow
If WorksheetFunction.IsNA(Cells(cCount, 2).Value) Or _
WorksheetFunction.IsNA(Cells(cCount + 1, 2).Value) _
Then GoTo SkipIt

If UCase(Cells(cCount, 2).Value) = _
UCase(Cells(cCount + 1, 2).Value) Then
With Range(Cells(cCount, 2), Cells(cCount + 1, 2)).Interior
.ColorIndex = acIndex(cIndex)
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Flag = True
End If
If Cells(cCount, 2).Value <> Cells(cCount + 1, 2).Value _
And Flag = True Then
cIndex = cIndex + 1
Flag = False
End If
SkipIt:

Next cCount
On Error GoTo 0

With Range(Cells(1, 1), Cells(LastRow, 3))
.Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Columns("C:C").Delete Shift:=xlToLeft

Range("B1").Select

Application.ScreenUpdating = True

End Sub

With regard to clearing the colours it hardly seems worth while because you
only have to hightlight the Column and click on "No Fill" on the drop down
pallete of the Fill Color button but if you want to do it in code then:

Sub UnColourIt()
Range("B:B").Interior.ColorIndex = xlNone
End Sub

Will do it for you.

If you want more colours in the colouring Macro then just add more numbers
into the array. To see what the Color Index number of the various colours
are then run this Macro on an empty sheet and the Row number will be the
Color Index:

Sub Colour()
Dim cIndex As Integer
For cIndex = 1 To 56
Cells(cIndex, 1).Interior.ColorIndex = cIndex
Next cIndex
End Sub

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk