Highlight cells with duplicate values, but each duplicate value a unique color. Excel Conditional Formatting - excel

Basically I'd like to highlight all duplicate cells with duplicate values. I've used conditional formatting to do this. The twist is, I would like each different, duplicate value to be highlighted a unique color.
For example,
If apple was found in three different cells, highlight them all red.
If orange was found in two different cells, high them all blue
etc. etc. and this will go on for hundreds of different, duplicate values... So I need it to generate slightly unique colors as well.
Any ideas? Thanks!
EDIT: I found a solution at this website: https://www.extendoffice.com/documents/excel/3772-excel-highlight-duplicate-values-in-different-colors.html although it costs money to install, this module, so if anyone has a different solution it would be greatly appreciated.

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
Found this VBA for Excel, it worked for me to organize and highlight multiple duplicates in different colors. Hope this helps.

I found a solution that uses KUTOOlS which can be found at the following website:
https://www.extendoffice.com/documents/excel/3772-excel-highlight-duplicate-values-in-different-colors.html
Insert a module in VBA and enter the following code:
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.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
Then press F5 to run the module.
(NOTE: This only works with KUTOOLS installed)

Related

VBA Paste Variable Range to Other Sheet?

I've got a macro set up to identify bad data, but when I try to copy only the clean data it throws an error (Error Code 1004). I'm using a For loop with a series of if statements to build the clean data range. Not sure why it is throwing this error as the line above "clean_Range.Interior.Color = Clean_Color" is working just fine and the "Data Sheet" tab appears to be active...
Any thoughts?
The data array is selected by the user, then we look at the limits of the upper and lower bounds to build the clean vs. dirty data array (~30 lines from the end).
Code and Image below:
Sub Data_cleanse()
'Perform Stats Analysis on Outlier Data.
'Specify Dims.....
Dim count_data_analyzed As Variant
Dim allRange As Range, aCell As Range, bCell As Range, selectedRng As Range
Dim ws_instruction As Worksheet, ws_data As Worksheet, ws_output As Worksheet, ws_cleansed As Worksheet
Dim record_cell As Variant, Upper_limit As Variant, Lower_limit As Variant, count_outliers As Variant
Dim percent_outliers As Variant
Dim AnswerYes As String, AnswerNo As String
Dim yesRange As Range, noRange As Range, dirty_range As Range, clean_Range As Range
'Highlight Outlier Data Points
Const yesColor As Long = 65280
Const noColor As Long = 65535
Const Clean_Color As Long = 65535
'Ascribe worksheets
Set ws_instruction = ThisWorkbook.Worksheets("Instruction Sheet")
Set ws_data = ThisWorkbook.Worksheets("Data Sheet")
Set ws_output = ThisWorkbook.Worksheets("Output Sheet")
Set ws_cleansed = ThisWorkbook.Worksheets("Cleansed Data")
ExcludeNegatives = MsgBox("Should all negative values be excluded from analysis?", vbQuestion + vbYesNo, "User Repsonse")
ExcludeZeros = MsgBox("Should zero values be excluded from analysis?", vbQuestion + vbYesNo, "User Repsonse")
Set selectedRng = Application.Selection
'Error handling to capture Cancel key.
On Error GoTo errHandler
'Define range.
Set selectedRng = Application.InputBox("Range", , selectedRng.Address, Type:=8)
record_cell = selectedRng.Address(ReferenceStyle:=xlA1, _
RowAbsolute:=False, ColumnAbsolute:=False)
'Cells(1, 9).Value = record_cell
'Cells(1, 10).Value = record_cell
'Format Output Information
ws_output.Cells(1, 1).Value = "Analysis Table"
ws_output.Cells(2, 1).Value = "Data Range Analyzed"
ws_output.Cells(6, 1).Value = "Upper Limit"
ws_output.Cells(7, 1).Value = "Lower Limit"
ws_output.Cells(8, 1).Value = "Number of Outliers"
ws_output.Cells(9, 1).Value = "Percent of Data"
Upper_limit = 15
Lower_limit = -20
If ExcludeNegatives = vbYes And Lower_limit < 0 Then
Lower_limit = 0
Else
Lower_limit = -20
End If
'If ExcludeZeros = vbYes Then...... may not need to do anything here.....
ws_output.Cells(2, 2).Value = record_cell
ws_output.Cells(6, 2).Value = Upper_limit
ws_output.Cells(7, 2).Value = Lower_limit
'Error Handling
On Error GoTo errHandler
'Build Array of Outlier Data
Set allRange = selectedRng
For Each aCell In allRange.Cells
If IsNumeric(aCell) Then ' maybe you don't need this...
If aCell.Value > Upper_limit Or aCell.Value < Lower_limit Then
If yesRange Is Nothing Then
Set yesRange = aCell
Else
Set yesRange = Union(aCell, yesRange)
End If
Else
If noRange Is Nothing Then
Set noRange = aCell
Else
Set noRange = Union(aCell, noRange)
End If
End If
End If
Next aCell
'Highlight Outlier Data
yesRange.Interior.Color = yesColor
'Build Array of Clean Data
For Each bCell In allRange.Cells
If IsNumeric(bCell) Then
If bCell.Value < Upper_limit And bCell.Value > Lower_limit Then
If clean_Range Is Nothing Then
Set clean_Range = bCell
Else
Set clean_Range = Union(bCell, clean_Range)
End If
Else
If dirty_range Is Nothing Then
Set dirty_range = bCell
Else
Set dirty_range = Union(bCell, dirty_range)
End If
End If
End If
Next bCell
'Highlight Clean Data
clean_Range.Interior.Color = Clean_Color
clean_Range.Copy
'ws_data.Range("A2").PasteSpecial
'Stop before running error handling.
Exit Sub
errHandler:
'Quit sub procedure when user clicks InputBox Cancel button.
If Err.Number = 424 Then
Exit Sub
Else: MsgBox "Error: " & Err.Number, vbOK
End If
End Sub

Excel VBA to split / format data vertically

I am trying to format and split a column of excel cells vertically. Each cell contains starts ICD-10: and then lots of codes separated with commas ",". I would like to Removed the ICD-10: and all of the spaces resulting in a column of just the individual codes. I found the following VBA code and have modified it to partly. I need to help removing the unwanted spaces and "ICD-10:" from the out put. I tried using trim and replace but I don't have a super firm understanding of exactly how this is working I just know it is close.
Any help is greatly appreciated.
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
If xStr = "" Then
xStr = xCell.Value
Else
xStr = xStr & "," & xCell.Value
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Sample Data
A1 = ICD-10: S7291XB, I4891, S0101XA, S7291XB, Z7901, V0300XA
A2 = ICD-10: S72431C, D62, E0590, E43, E785, E872, F321, G4700, I129, I2510, I441, I4891, I4892, I959, N183, R339, S0101XA, S01111A, S32591A, S7010XA, S72431C, Z6823, Z7901, Z87891, Y92481, S72351B
Thanks for the help.
You have a very good beginning. With only 3 more lines of code, we can make it happen. I don't know what happens then the output range xOutRg is more than one cell.
Option Explicit ' ALWAYS
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
'just get the input value(s), then remove ICD-10, then remove any spaces
xTxt = xCell.Value
xTxt = Replace(xTxt, "ICD-10:", "")
xTxt = Replace(xTxt, " ", "")
' then append xTxt (not original cell)
If xStr = "" Then
xStr = xTxt
Else
xStr = xStr & "," & xTxt
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Here's code that will split the cells in the way you describe. It works very fast but please take the time to read all the comments carefully. Some of them are just informative but others may require your action. In this regard, pay attention to the names I have given to the variables. A name like FirstDataRow will help you know what you should adjust.
Sub SplitCellsToList()
Const FirstDataRow As Long = 2 ' change to suit
Const InputColumn As Long = 1 ' change to suit (1 = column A)
Dim OutCell As Range ' first cell of output list
Dim InArr As Variant ' array of input values
Dim OutArr As Variant ' array of output values
Dim n As Long ' row index of OutArr
Dim Sp() As String ' Split cell value
Dim i As Integer ' index of Split
Dim R As Long ' loop counter: sheet rows
Set OutCell = Sheet1.Cells(2, "D") ' change to suit
With ActiveSheet
InArr = .Range(.Cells(FirstDataRow, InputColumn), _
.Cells(.Rows.Count, InputColumn).End(xlUp)).Value
End With
ReDim OutArr(1 To 5000) ' increase if required
' 5000 is a number intended to be larger by a significant margin
' than the total number of codes expected in the output
For R = 1 To UBound(InArr)
Sp = Split(InArr(R, 1), ":")
If UBound(Sp) Then
Sp = Split(Sp(1), ",")
For i = 0 To UBound(Sp)
Sp(i) = Trim(Sp(i))
If Len(Sp(i)) Then
n = n + 1
OutArr(n) = Sp(i)
End If
Next i
Else
' leave the string untreated if no colon is found in it
n = n + 1
OutArr(n) = InArr(R, 1)
End If
Next R
If n Then
ReDim Preserve OutArr(1 To n)
OutCell.Resize(n).Value = Application.Transpose(OutArr)
End If
End Sub

Count cell change individually

I have a little problem. I edited a code to count the cell changes for the selected cell what actually works great. This code goes into the sheets coding not as an individual macro to run.
How is possible to run the same code in parallel for different area counting separately from the other one watching different cells.
I tried with double IF what gave me an error and I tried the same code under different sub.
For the moment the code watching the C8 cells change and counts in D8.
I need to run another counter for C16 and to count in D18.
If I need to monitor multiple cells with separate counters how can I do it ?
Dim xCount As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range, xCell As Range
On Error Resume Next
If Target = Range("C8") Then
xCount = xCount + 1
Range("D8").Value = xCount
End If
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("C8"))
If Not xRg Is Nothing Then
xCount = xCount + 1
Range("D8").Value = xCount
End If
Application.EnableEvents = True
End Sub
EDITED:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range, xCell As Range, ranges, x As Long
Dim deps As Range
If Target.Count > 1 Then Exit Sub '<<<<<<<< added this...
On Error GoTo haveError
ranges = Array("C8", "C16")
For x = 0 To UBound(ranges)
Set xCell = Range(ranges(x))
If Not Application.Intersect(Target, xCell) Is Nothing Then
Application.EnableEvents = False
xCell.Offset(0, 1).Value = xCell.Offset(0, 1).Value + 1
End If
Set deps = Nothing
On Error Resume Next 'suspend error trapping
Set deps = Target.Dependents
On Error GoTo haveError 'resume trapping
If Not deps Is Nothing Then
Set xRg = Application.Intersect(Target.Dependents, xCell)
If Not xRg Is Nothing Then
Application.EnableEvents = False
xCell.Offset(0, 1).Value = xCell.Offset(0, 1).Value + 1
End If
End If
Next x
haveError:
Application.EnableEvents = True
End Sub

Highlight rows with different colors by groups of duplicates

How do I highlight rows with different colors by groups of duplicates?
I don't care about which colors are used per se, I just want the duplicate rows one color, and the next set of duplicates another color.
For example, if I wanted the '1s' green, the '2s' blue and so on. It goes up to 120 in my column.
Thank you.
The solution by Gowtham is only specific to numbers and uses VBA. You can use the following workaround that works with any type of data and doesn't need VBA.
We could use another column that generates a unique value for all the duplicates using a formula and use the "Conditional Formatting > Color Scales" for that column. Screenshot below.
The formula that you can use is
"=ROW(INDEX(A$2:A$12,MATCH(A2,A$2:A$12,0)))"
In the above formula, A$2:A$12 is the range that we want to search for duplicates.
The formula basically searches for the first instance of the duplicate value in the given range and inputs the row number of that first instance.
P.S: In the above formula, the range "A$2:A$12" is a fixed range, using the above formula in a Table is much simpler as a Table Range is dynamic
One other benefit of using Table is that we can even sort the data to group the duplicate values together
=ROW(INDEX([Column1],MATCH(A2,[Column1],0)))
Try out this simple code and modify it per your needs. Its quite self explanatory,
Sub dupColors()
Dim i As Long, cIndex As Long
cIndex = 3
Cells(1, 1).Interior.ColorIndex = cIndex
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i + 1, 1).Interior.ColorIndex = cIndex
Else
If Cells(i + 1, 1) <> "" Then
cIndex = cIndex + 1
Cells(i + 1, 1).Interior.ColorIndex = cIndex
End If
End If
Next i
End Sub
Gowtham's answer is great, and I wouldn't have figured out the below without them! I had the same need for unique color assignment, however, I needed more variance than the 56 colors that colorindex provides, so I slightly modified Gowtham's code to provide a bit more variability by using RandBetween along with RGB to create randomized colors via randomized red, blue, and green values.
I kept the color range between 120 & 255, since some of the lower values could result in cells that were too dark to read, but you can certainly customize to your liking. The code below can certainly be improved upon, as I'm no expert, but it was able to obtain the 100+ colors needed.
EDIT: I will add that there is a possibility that RGB values could overlap. I just needed to color-code for visual aid; but if you will need strict unique color values, this code will not guarantee that.
Dim rCount, RandCol1, RandCol2, RandCol3, i As Long
rCount = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rCount
If Sheet1.Cells(i, 1) = Sheet1.Cells(i + 1, 1) Then
Sheet1.Cells(i + 1, 1).Interior.Color = RGB(RandCol1, RandCol2, RandCol3)
Else
If Sheet1.Cells(i + 1, 1) <> "" Then
RandCol1 = WorksheetFunction.RandBetween(120, 255)
RandCol2 = WorksheetFunction.RandBetween(120, 255)
RandCol3 = WorksheetFunction.RandBetween(120, 255)
Sheet1.Cells(i + 1, 1).Interior.Color = RGB(RandCol1, RandCol2, RandCol3)
End If
End If
Next i
I found this VBA in https://www.extendoffice.com/documents/excel/3772-excel-highlight-duplicate-values-in-different-colors.html:
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
Found this code for excel VBA that worked to organize a large number of duplicates in different colors.
`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

Run Time Error '1004': Select method of Range Class failed VBA

I am getting a run time error on the below code , can you please assist.
The part and getting the error on is rngRange.Select. Can you advise in any way in which i can amend the below code? Thank you in advance
Sub NameRangeTop(Optional ByRef rngRange As Range)
If rngRange Is Nothing Then
Set rngRange = Application.Selection
Else
rngRange.Select
End If
Dim ActiveRange As Range
Dim NumRows, NumColumns, iCount As Long
Dim CurSheetName As String
CurSheetName = ActiveSheet.Name
Set ActiveRange = Selection.CurrentRegion
ActiveRange.Select
NumRows = ActiveRange.Rows.Count
NumColumns = ActiveRange.Columns.Count
If NumRows = 1 And NumColumns = 1 Then
MsgBox "No active cells in the surrounding area. Try running the macro from a different location", vbCritical, "Local Range Naming"
Exit Sub
End If
If NumRows = 1 Then
Set ActiveRange = ActiveRange.Resize(2)
NumRows = 2
End If
For iCount = 1 To NumColumns
ActiveRange.Resize(NumRows - 1).Offset(1, 0).Columns(iCount).Name = CurSheetName & "!" & ActiveRange.Rows(1).Columns(iCount).Value
Next
ActiveRange.Resize(NumRows - 1).Offset(1, 0).Select
End Sub
it's because the passed rngRangerange doesn't belong to currently active worksheet
code like this
If rngRange Is Nothing Then
Set rngRange = Application.Selection
Else
rngRange.Parent.Activate
rngRange.Select
End If

Resources