Highlight Duplicate Values In Different Colours AND ignore blanks

[dslhs]

Hi,

I've borrowed a VBA code from another site that allows me to highlight duplicate values in different colours:

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

This works like a charm, but I want it to ignore blank cells (the blank cells have an array formula but no result). How do I amend this VBA to do that?

Many thanks,

 

[DanteAmor]

Try this:

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
    If xCell <> "" Then
      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
    End If
  Next
End Sub

 

[dslhs]

Hero! That works perfectly. Thank you

 

[Peter_SSs]

@dslhs
When posting vba code in the forum, please use the available code tags. It makes the code much easier to read and debug.
My signature block below has more details.
I have added the tags for you this time.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[dslhs]

Hi,

Just a follow-up - is there a way of setting it so that the same colour is used for the same value across the whole workbook (multiple sheets). Because it picks at random for each sheet, when it finds Student 1 in Sheet 1 - it makes it Green. But then I run again in Sheet 2 - it makes Student 1 Blue.

Many thanks,

 

[dslhs]

Any ideas on the above? It would be very useful and I can't work it out myself

 

[Peter_SSs]

Any ideas on the above? It would be very useful and I can't work it out myself

I've borrowed a VBA code from another site

Have you asked at the site you got the code from?

 

[dslhs]

Yes- but no response.

I'm basically looking for a VBA that-
- identifies duplicates across the whole workbook/multiple sheets
- highlights duplicate cells to same random colour (preferably a light colour so text is still visible)
- ignores blank cells

Is this possible?