· 21 days ago
this code left some duplicates with no fill (often those with one pair) can u check the code why and give me new please? ps. document have 6000+ positions and sometimes 5 to 10 duplicates
How to highlight duplicate values in different colors in Excel?
In Excel, we can easily highlight the duplicate values in a column with one color by using the Conditional Formatting, but, sometimes, we need to highlight the duplicate values in different colors to recognize the duplicates quickly and easily as following screenshot shown. How could you solve this task in Excel?
Highlight duplicate values in a column with different colors by using VBA code
Highlight duplicate values in a column with different colors by using VBA code
In fact, there is no direct way for us to finish this job in Excel, but, the below VBA code may help you, please do as follows:
1. Select the column of values that you want to highlight duplicates with difference colors, then hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.
2. Click Insert > Module, and paste the following code in the Module Window.
VBA code: Highlight duplicate values in different colors:
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub
3. And then press F5 key to run this code, and a prompt box will remind you to select the data range that you want to highlight the duplicate values, see screenshot:
4. Then click OK button, all the duplicate values have been highlighted in different colors, see screenshot:
The Best Office Productivity Tools
Kutools for Excel Solves Most of Your Problems, and Increases Your Productivity by 80%
- Reuse: Quickly insert complex formulas, charts and anything that you have used before; Encrypt Cells with password; Create Mailing List and send emails...
- Super Formula Bar (easily edit multiple lines of text and formula); Reading Layout (easily read and edit large numbers of cells); Paste to Filtered Range...
- Merge Cells/Rows/Columns without losing Data; Split Cells Content; Combine Duplicate Rows/Columns... Prevent Duplicate Cells; Compare Ranges...
- Select Duplicate or Unique Rows; Select Blank Rows (all cells are empty); Super Find and Fuzzy Find in Many Workbooks; Random Select...
- Exact Copy Multiple Cells without changing formula reference; Auto Create References to Multiple Sheets; Insert Bullets, Check Boxes and more...
- Extract Text, Add Text, Remove by Position, Remove Space; Create and Print Paging Subtotals; Convert Between Cells Content and Comments...
- Super Filter (save and apply filter schemes to other sheets); Advanced Sort by month/week/day, frequency and more; Special Filter by bold, italic...
- Combine Workbooks and WorkSheets; Merge Tables based on key columns; Split Data into Multiple Sheets; Batch Convert xls, xlsx and PDF...
- More than 300 powerful features. Supports Office/Excel 2007-2019 and 365. Supports all languages. Easy deploying in your enterprise or organization. Full features 30-day free trial. 60-day money back guarantee.
Office Tab Brings Tabbed interface to Office, and Make Your Work Much Easier
- Enable tabbed editing and reading in Word, Excel, PowerPoint, Publisher, Access, Visio and Project.
- Open and create multiple documents in new tabs of the same window, rather than in new windows.
- Increases your productivity by 50%, and reduces hundreds of mouse clicks for you every day!
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.Excel crashes everytime I attempt running one of your codes:Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.EntireRow.Interior.ColorIndex = xCIndex
xCell.EntireRow.Interior.ColorIndex = xCellPre.EntireRow.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End SubI have tried running in safe mode and It still crashes. I'm in the most recent version of excel. Any suggestions? - To post as a guest, your comment is unpublished.Hi, is there any way to have this code ignore empty cells? When I put in the code it highlighted all of the empty cells and I need them to be blank.Thank you!
- To post as a guest, your comment is unpublished.Hi, Sadie,To ignore the empty cells, please apply the below code:Sub ColorCompanyDuplicates() 'Updateby Extendoffice Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim I As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next If xCell.Value <> "" Then xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 End If Next End SubPlease try, hope it can help you!
- To post as a guest, your comment is unpublished.IS THERE ANY VBA CODE TO HIGHLIGHT DUPLICATES BY DIFFERENT FONT COLORS?
- To post as a guest, your comment is unpublished.Hello, sajith,To highlight the duplicates with different font colors, please apply the below formula:Sub ColorCompanyDuplicates() 'Updateby Extendoffice Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim I As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Font.ThemeColor = xlNone Then xCellPre.Font.ThemeColor = xCIndex xCell.Font.ThemeColor = xCellPre.Font.ThemeColor ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 Next End SubPlease try, hope it can help you!
- To post as a guest, your comment is unpublished.Hello I need help highlighting cells only if they repeat consecutively with 2 cell colors. This is a sample of end result.958368
94
97
95.** Highlight with color 1
95 ** Highlight with color 1
95** Highlight with color 1
78
92
65
85
79
94
83
91
68** Highlight with 2nd color
68** Highlight with 2nd color
68** Highlight with 2nd color807083**Highlight with color 183**Highlight with color 19465831265** Highlight with 2nd color65** Highlight with 2nd color65** Highlight with 2nd color - To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.You are champion..!!!
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.this macro stops after every 100 rows. I ahve dtaa with more than 5000 rows. then What Should i do with the code.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.Whenever I run this code it seems to work for a few seconds (I can see the various colors in the appropriate column...) but when I try to scroll down to see the entire sheet, everything freezes. Eventually I get an error message that Excel is not responding... Any suggestions? My guess is that my spreadsheet is too large? Or I have too many Duplicate Vales and it's throwing Excel for a loop?? i.e. Recent spreadsheet had 567 cells in the column I was attempting to format and there were around 267 duplicates... Too much? Not enough colors in the rainbow, possibly? ;)
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.I'm a beginner (obviously), but I keep getting the following error "Compile Error: Invalid outside procedure." Any suggestions?
- To post as a guest, your comment is unpublished.Hallo and thx for your work - know its long time ago but still great to use
I use it in a large address list and filter out all double entry’s - help a lot
Now my question - is it possible to run this macro in some kind of live error check - I mean - if someone enter a doable address it get colored directly when I press enter.
Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20171222
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Range("M10:P10010")
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.Color = RGB(xRed, xGreen, xBlue)
xCell.Interior.Color = xCellPre.Interior.Color
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
xRed = Application.WorksheetFunction.RandBetween(0, 255)
xGreen = Application.WorksheetFunction.RandBetween(0, 255)
xBlue = Application.WorksheetFunction.RandBetween(0, 255)
On Error GoTo 0
End If
Next
End Sub
Thx for your help - To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.Because you are limited to 56 Colours using the *.ColorIndex you should probably consider using RGB colours.
I have modified the code (note there is no if-statement for duplicate coloruing)…
Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20160704
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.Color = RGB(xRed, xGreen, xBlue)
xCell.Interior.Color = xCellPre.Interior.Color
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
xRed = Application.WorksheetFunction.RandBetween(0, 255)
xGreen = Application.WorksheetFunction.RandBetween(0, 255)
xBlue = Application.WorksheetFunction.RandBetween(0, 255)
On Error GoTo 0
Next
End Sub- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.How can you make it color the entire document if there are many rows?
- To post as a guest, your comment is unpublished.Hi, AW,
To highlight entire documnet based on the duplicate cell values, you can apply the following VBA code:
Sub ColorCompanyDuplicates()
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.EntireRow.Interior.ColorIndex = xCIndex
xCell.EntireRow.Interior.ColorIndex = xCellPre.EntireRow.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub
Please try it, hope it can help you!
- To post as a guest, your comment is unpublished.Thanks for posting this, it's been very helpful! Which lines in the VBA code designate which colors will be used? I was looking for hex color codes in there but nothing was popping out.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.My spreadsheet also stopped coloring at 178 and I have over 400 lines. How do you fix this?
- To post as a guest, your comment is unpublished.This is really great, but colouring stopped after row 76 (5 colours). How can I this be extended too?
- To post as a guest, your comment is unpublished.This is really great, but colouring stopped after row 66 (9 colours). How can I this be extended?
- To post as a guest, your comment is unpublished.Hello, Anri,
The above code works well in my worksheet, i test it in 300 hundred rows.
Please try it again. Or you can send your workbook file to my email account.
My email account is: skyyang@extendoffice.com- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.there is some mistake regarding the colorindex setting, xCindex will be more than 56 if there are 56 row data in your sheet, system will ignore the sentence :
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
I correct the program like below: \
if Err.number=457 then
if xCellPre.Text<>xCell.Text Then
xCindex=xCindex+1
endif
set.....
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.Is there a way to change the script to work for (look at) table array instead of column? For example F2:BC117.
Thank you!- To post as a guest, your comment is unpublished.Hello, Vasil,
To highlight duplicate values in a range of cell, please try the following vba code:
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg, xRgRow As Range
Dim xTxt, xStr As String
Dim xCell, xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For I = 1 To xRg.Rows.Count
On Error Resume Next
Set xRgRow = xRg.Rows(I)
For Each xCell In xRgRow.Columns
xStr = xStr & xCell.Text
Next
xCol.Add xRgRow, xStr
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xStr)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xRgRow.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
xStr = ""
Next
End Sub
Hope it can help you.
- To post as a guest, your comment is unpublished.Is there a way to highlight the entire row instead of 1 column?
- To post as a guest, your comment is unpublished.Hi, Bobo,
To highlight entire row based on the duplicate cell values, you can apply the following VBA code:
Sub ColorCompanyDuplicates()
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.EntireRow.Interior.ColorIndex = xCIndex
xCell.EntireRow.Interior.ColorIndex = xCellPre.EntireRow.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub
Please try it, hope it can help you!- To post as a guest, your comment is unpublished.how can I highlight the range of rows?
- To post as a guest, your comment is unpublished.Hello, Hossein,
May be the following code can do you a favor, please try it.
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg, xRgRow As Range
Dim xTxt, xStr As String
Dim xCell, xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For I = 1 To xRg.Rows.Count
On Error Resume Next
Set xRgRow = xRg.Rows(I)
For Each xCell In xRgRow.Columns
xStr = xStr & xCell.Text
Next
xCol.Add xRgRow, xStr
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xStr)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xRgRow.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
xStr = ""
Next
End Sub
- To post as a guest, your comment is unpublished.What If I just want to fill with only two colors, let's say yellow and red, repeatedly. To be clear, on the example in this page, 'Rachel' is yellow, Rose is red and again Sussies are yellow, Tedi is red.
- To post as a guest, your comment is unpublished.Hello, selim,
The following code may solve your problem, please try.
Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20170504
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xRgTemp As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 3
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
Set xCellPre = xCol(xCell.Text)
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
Else
xCell.Interior.ColorIndex = xCIndex
Set xRgTemp = xCell
xCIndex = IIf(xRgTemp.Interior.ColorIndex = 3, 4, 3)
End If
On Error GoTo 0
Next
End Sub
Hope it can help you!
- To post as a guest, your comment is unpublished.Hello, I have Excel 2016, alt+F11 does work anymore to bring up Microsoft VB? is Microsoft visual basic free software? Thank you.
- To post as a guest, your comment is unpublished.Sir,
How to differentiate different colors given in the data on the basis of frequency?
In very large data same color has been given repeatedly without considering their frequency. - To post as a guest, your comment is unpublished.without empty to change a colour how ????????????????????
- To post as a guest, your comment is unpublished.Hello, gopi,
To avoid the blank cells, please apply the following VBA code:
Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20171222
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
End If
Next
End Sub
Hope it can help you, thank you!
- To post as a guest, your comment is unpublished.how to change colour ?
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.Hi，
The code only can help you add the different color randomly, it can't change the color.
Thank you!
- To post as a guest, your comment is unpublished.I am really happy as I got what I was needed. Thanks
- To post as a guest, your comment is unpublished.This is great and EXACTLY what I was looking for! I'm incorporating this code into some existing code - I've written my code to select the cells that I want to color, and then I call the code to do the coloring. The only thing I can't figure out is how to bypass the msgBox that pops up and I have to click OK. I'm a novice at VBA and can't quite figure out how to alter this code.... Any suggestions, please! :)
- To post as a guest, your comment is unpublished.Replace line: Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
to
Set xRg = Range("A1:A100")
or if you have table you can apply to whole table column:
Set xRg = Range("Table1[[#All],[Column1]]")
just replace Table1 to your own name and Column1 to any table header you wish to apply this macro.
Regards
Wojciech
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.I had the same problem, the problem is the color index only goes to 56, so once it passes that it no longer colors the cells. To fix that, I replaced the line "xCIndex = xCIndex + 1" with the following:
If xCIndex > 55 Then
xCIndex = 3
Else
xCIndex = xCIndex + 1
End If
It will start reusing colors eventually, but that wasn't an issue for me.- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.The replace with
If xCIndex > 55 Then
xCIndex = 3
Else
xCIndex = xCIndex + 1
End If
Did not work. Trying to get this to work on 14000 lines, approx 6000 duplicates
- To post as a guest, your comment is unpublished.
- To post as a guest, your comment is unpublished.This has been a life saver for me, thank you so much for sharing!
When I run it on about 2000 cells with values, it only highlights some of the duplicates. Is there a way to fix that? I wonder if it runs out of colors or there is something else. - To post as a guest, your comment is unpublished.i want to check the duplicates for 5000 cells which i am not able to do. i can highlight duplicates upto 70 to 80 cells
- To post as a guest, your comment is unpublished.Sub BuscarD()
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCol As Collection
Dim I As Long
Dim J As Integer
Dim K As Integer
Dim xCLR As Integer
xCLR = 28
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Seleccione el rango a evaluar:", "Buscar duplicados", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
J = 0
K = 0
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then
xCellPre.Interior.Color = RGB(255, J, K)
xCell.Interior.Color = RGB(255, J, K)
If K + xCLR <= 255 Then
K = K + xCLR
Else
If J + xCLR <= 255 Then
K = 0
J = J + xCLR
Else
MsgBox "!Demasiados datos duplicados!: Reducir variable xCLR", vbCritical, "Error"
Exit Sub
End If
End If
Else
xCell.Interior.Color = xCellPre.Interior.Color
End If
ElseIf Err.Number = 9 Then
MsgBox "Demasiados datos duplicados!", vbCritical, "Error"
Exit Sub
End If
On Error GoTo 0
Next
End SubEs un tema viejo, pero lo dejo por si alguien lo necesita. Con el código anterior y modificando la variable "xCLR", desde 1 a 255, se pueden obtener desde 4 hasta 65.000 colores diferentes. En mi caso, configuré el rojo del RGB con un valor estático de 255 y varío los valores verde y azul (255, X, X). Si se requieren mas colores, se podría alterar el valor del rojo, logrando mas de 166 millones de colores diferentes
- To post as a guest, your comment is unpublished.This is just what I needed, thank you.
Sometimes when I run this code Excel just freezes, I am using Office 2016 / Windows 10 any idea why? - To post as a guest, your comment is unpublished.It worked for me on a list of part numbers.
