Unique Blanks

[billandrew]

Afternoon all

This Script highlights Unique values in Range A:C - Only issue is that it also highlights blanks which are in the Dic. Is there a way to exclude prior to adding to dictionary I suppose?



Thank You

Sub hUnique()Dim lastrow As Long
Dim r As Range
Dim dic As Object
lastrow = Cells.Find(what:="*", LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious, searchformat:=False).Row


Set dic = CreateObject("Scripting.dictionary")
With dic
.comparemode = vbTextCompare


For Each r In Range("A1:C" & lastrow)
If Not dic.exists(r.Value) Then
.Add r.Value, ""
r.Interior.Color = RGB(218, 239, 245)


End If
Next r
End With
Cells(1, 8).Value = dic.Count
End Sub

 

[Fluff]

Try

For Each r In Range("A1:C" & LastRow)
   If Not Dic.Exists(r.Value) [COLOR=#0000ff]And r.Value <> ""[/COLOR] Then
      .Add r.Value, ""
      r.Interior.Color = RGB(218, 239, 245)
   End If
Next r

 

[billandrew]

Thank You Fluff. Perfect!

Happy New Year!

 

[Fluff]

You're welcome & thanks for the feedback