• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Highlight rows with colors

IKHAN

Member
Hi, Looking for a macro to Highlight row if matching values found in column A.


EXAMPLE :

Column A

1234

1234

2345

2345

1234


Highlight values 1234 found row with color yellow and 2345 values with colour light green and alternate same colors if different numbers match.


Help is really apprecicated !!!
 
It would probably be simpler and faster to just use conditional formatting to highlight duplicate cells. A CF formula similar to:

=COUNTIF(A:A,A2)>1

would work.
 
Good day IKHAN


Use conditional formatting. Do not know what version of Excel you are using but with 2010, go to the conditional formatting on the home tab of the ribbon, on the drop down choose High Cell Rules, and then choose Equal To. In the dialogue box in the "Format cells that are EQUAL TO:" put 1234 and then click on the drop down pointing arrow head to format with colour. Do the same for other numbers.

Before you do any of the above HIGH LIGHT your range of data FIRST.
 
Thanks bobhc..I have different numbers each time..not neccessary 1234, 2345 ..it cld be 1000 lines with different numbers each time.
 
Good evening IKHAN

Generally speaking, any computer, depending on the graphics card and monitor, is physically capable of displaying color in the following depths:


1-bit color (2 colors)

2-bit color (4 colors)

4-bit color (16 colors)

8-bit color (256 colors)

16-bit color (65535 colors)

24-bit color (16.7 million colors)


Most "32-bit" displays do not display 4.2 billion colors, like you would expect. Instead, they display 24-bit color and use the remaining 8 bits to signal alpha transparency or Z-buffer data. Most 64-bit computers still use 24-bit or 32-bit color. Since the human eye cannot distinguish anywhere close to the 18.4 quintillion colors a 64-bit display would provide, a 64-bit display is unlikely to ever be used.


This means that you will ONLY be able to insert over 16 million pieces of data into your data cells before having to reuse a colour, however I must be honest and say a formula to colour all numbers different on this scale is a little bit beyond me.


I can not wait to see what the Ninjas come up with to do this, it must be one hell of a formula :)
 
To help out IKHAN, original statement was

and alternate same colors if different numbers match.

So we only need to worry about 2 colors. The problem is that it may alternate over several thousand different numbers, so we need to come up with some way of keeping count of how many unique duplicates we've encounted and color them yellow or green. Still working on trying to find a solution...
 
Sorry for this Luke M..............But"if different numbers match" then they must be the same number or they are within a range of set limits, if they fall within set limits could you not CF the range limits?, if they are "different numbers match" how do they match?? I know, I know but I think a person has the right to ask one dumb question a day :)
 
Well, I gave up on a CF formula, and went to a macro. All code needs to be put into a regular module (not a sheet module) and then run the HighlightRows macro.

Sub HighlightRows()
Dim LastRow As Integer
Dim SearchRange As Range
Dim FoundCells As Range
Dim c as Range
Dim SearchValue As Variant
Dim ColorChoice As Boolean

'how many rows do we have?
LastRow = Range("A65536").End(xlUp).Row

If LastRow < 2 Then Exit Sub 'No data found

'define the search range
Set SearchRange = Range("A2", Cells(LastRow, "A"))
ColorChoice = True
Application.ScreenUpdating = False
For Each c In SearchRange
If c.Interior.ColorIndex < 0 Then 'If not already colored
SearchValue = c.Value
'Check if it's a duplicate
If WorksheetFunction.CountIf(SearchRange, SearchValue) > 1 Then

'find all the cells of interest
Set FoundCells = FindAll(SearchRange, SearchValue)

'color the rows
If ColorChoice Then
FoundCells.EntireRow.Interior.ColorIndex = 6 'yellow
Else
FoundCells.EntireRow.Interior.ColorIndex = 21 'light green
End If
'Flip out color switch
ColorChoice = Not (ColorChoice)
End If
End If
Next c
Application.ScreenUpdating = True

End Sub

'The following was found from Chip Pearson's site
'http://www.cpearson.com/excel/findall.aspx
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean

CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If

' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.

For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)

If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If

Loop
End If

Set FindAll = ResultRange

End Function
 
@bobhc


Here's how I understood the question and desired output

[pre]
Code:
1234  yellow  'All rows with 1234 get colors same color
4567  <blank> 'not a duplicate value, so no color
1234  yellow  'duplicate value, but already found. All 1234's are yellow
2345  green   'new duplicate value. Gets alternate color of green
2345  green   'duplicate value already found. all 2345's are green
1234  yellow
1234  yellow
Now, this does get a little confusing if data is like this:

1234  yellow  'All rows with 1234 get colors same color
4567  <blank> 'not a duplicate value, so no color
1234  yellow  'duplicate value, but already found. All 1234's are yellow
2345  green   'new duplicate value. Gets alternate color of green
2345  green   'duplicate value already found. all 2345's are green
1234  yellow
1234  yellow
9874  yellow  'new duplicate value, but as last unique duplicate was 2345 and green,
9874  yellow  'the 9874's are yellow
[/pre]
@IKHAN

Please advise if I have interpreted your wishes incorrectly.
 
Hi, IKHAN!


Give a look at this file:

https://dl.dropbox.com/u/60558749/Highlight%20rows%20with%20colors%20%28for%20IKHAN%20at%20chandoo.org%29.xlsm


You enter a number in B1 and get differently painted up to 16777216 rows, if Excel'd let you. Disclaimer: I don't know who in the hell could distinguish them, but's not my problem :)


Regards!


@b(ut)ob(ut)hc

Hi!

Don't push on me when I'm playing NFS, please...

Regards!


@Luke M

Hi!

Just for your CASFFML...

Regards!


-----

[pre]
Code:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' constants
Const ksInputRange = "B1"
Const ksOutputRange = "2:1048576"
Const kiColorMax = 255
' declarations
Dim I As Long, J As Long, K As Long, lColor As Long, bOk As Boolean
Dim rng As Range, rngC As Range
' start
If Application.Intersect(Target, Range(ksInputRange)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set rng = Range(ksOutputRange)
Set rngC = rng.Columns(1)
' process
'  retrieve rows
I = Val(Range(ksInputRange).Value)
If I = 0 Then Exit Sub
'  clear previous backcolor
With rng
.ClearContents
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
'  paint new backcolor
'   set random seed
Randomize
'   play
For J = 1 To I
With rng.Rows(J).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
' method 1: VBA only, keep commented GoTo A
' method 2: Excel function, remove comment from GoTo A (default, much faster)
GoTo A
bOk = False
Do Until bOk
lColor = RGB(kiColorMax * Rnd, kiColorMax * Rnd, kiColorMax * Rnd)
bOk = True
For K = 1 To J
If rngC.Cells(K, 1).Value = lColor Then
bOk = False
Exit For
End If
Next K
DoEvents
Loop
rngC.Cells(J, 1).Value = lColor
GoTo B
A:
Do
lColor = RGB(kiColorMax * Rnd, kiColorMax * Rnd, kiColorMax * Rnd)
rngC.Cells(J, 1).Value = lColor
DoEvents
Loop Until Application.WorksheetFunction.CountIf(rngC, lColor) = 1
B:
.Color = lColor
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next J
' end
Application.ScreenUpdating = True
Range(ksInputRange).Offset(0, 1).Select
Beep
End Sub
[/pre]
-----
 
I do not "push" just a gentle nudge in the ribs :)


IKHAN do you see what you have started :)
 
Sorry ..i was away..Wow Thts a lot of discussion....My spreadsheet will be sorted , so alternate colors would do.After macro is executed, I shld be able to edit sheet and change colors if needed..


1234...yellow complete row

1234..yellow complete row

1234..yellow complete row

2345..green complete row

2345..green complete row

4356..yellow complete row

4356..yellow complete row

4356..yellow complete row

6789..green complete row

6789..green complete row

7898..no match...yellow

8767..no match...green


Thank you guys for all your help
 
Hi, IKHAN!

Glad to help and welcome back whenever needed or wanted.

Regards!


@b(ut)ob(ut)hc

Hi!

Please get a fine blow in the neck :)

Regards!
 
Back
Top