Unique Values Macro

[nirvehex]

Hi, I have code that I use as a personal macro on my ribbon that lets you highlight a list of cells and it pastes this to another tab and removes duplicates so I can get a unique count:

Sub List_Unique_Values()
'Create a list of unique values from the selected column


Dim rSelection As Range
Dim ws As Worksheet
Dim vArray() As Long
Dim i As Long
Dim iColCount As Long


  'Check that a range is selected
  If TypeName(Selection) <> "Range" Then
    MsgBox "Please select a range first.", vbOKOnly, "List Unique Values Macro"
    Exit Sub
  End If
  
  'Store the selected range
  Set rSelection = Selection


  'Add a new worksheet
  Set ws = Worksheets.Add
  
  'Copy/paste selection to the new sheet
  rSelection.Copy
  
  With ws.Range("A1")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    '.PasteSpecial xlPasteValuesAndNumberFormats
  End With
  
  'Load array with column count
  'For use when multiple columns are selected
  iColCount = rSelection.Columns.Count
  ReDim vArray(1 To iColCount)
  For i = 1 To iColCount
    vArray(i) = i
  Next i
  
  'Remove duplicates
  ws.UsedRange.RemoveDuplicates Columns:=vArray(i - 1), Header:=xlGuess
  
  'Remove blank cells
  On Error Resume Next
    ws.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
  On Error GoTo 0
  
  'Autofit column
  ws.Columns("A").AutoFit
  
  'Exit CutCopyMode
  Application.CutCopyMode = False
    
End Sub

However, I have to always then delete the tab that it creates. I'm wondering, can this be modified to just pop up a dialogue box that shows the unique count so I do is see the count and then click ok?

Thanks!

 

[Eric W]

How about:

Sub countUniques()
Dim MyDict As Object, c As Range

    Set MyDict = CreateObject("Scripting.Dictionary")
    For Each c In Selection
        MyDict(CStr(c)) = 1
    Next c
    MsgBox "There are " & MyDict.Count & " unique items in the selection"
    Set MyDict = Nothing
    
End Sub

 

[Domenic]

The following macro uses the Dictionary object to obtain a unique count from the selected cells, and then simply displays the unique count. As per your example, when multiple columns are selected, the unique count is obtained from the last column.

Option Explicit

Sub GetUniqueCountFromRangeSelection()

    Dim dicUnique As Object
    Dim rngColumn As Range
    Dim rngCell As Range
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Please select a range, and try again.", vbOKOnly, "Unique Count"
        Exit Sub
    End If
    
    Set dicUnique = CreateObject("Scripting.Dictionary")
    dicUnique.CompareMode = 1  ' 1 = case-insensitive comparison, 0 = case-sensitive comparison
    
    With Selection
        Set rngColumn = .Columns(.Columns.Count)
    End With
    
    For Each rngCell In rngColumn.Cells
        If Not dicUnique.Exists(rngCell.Value) Then
            dicUnique.Add Key:=rngCell.Value, Item:=""
        End If
    Next rngCell
    
    MsgBox "Unique count:  " & dicUnique.Count, vbInformation, "Unique Count"
    
    Set dicUnique = Nothing
    Set rngColumn = Nothing
    Set rngCell = Nothing
    
End Sub

Hope this helps!

 

[nirvehex]

Thanks, I went with Eric W's since it was nice and short. Thanks to both of you though! Appreciate your time!

 

[Eric W]

Glad we could help.

It's probably worth noting that Dominic's macro is a bit longer since he has logic to only count unique values in the last column, plus he has some better error handling. If either of those becomes an issue, you may want to look at his again.

 

[nirvehex]

Hi guys, got another question - I noticed the code that Eric wrote counts everything in a selection even if I have a filter on. Anyway to make it count only the selection that it's filtered to. Like if I have cells that are filtered out, it won't include those?

 

[Eric W]

I'll let Dominic update his version, but you can easily update mine like so:

Sub countUniques()
Dim MyDict As Object, c As Range


    Set MyDict = CreateObject("Scripting.Dictionary")
    For Each c In Selection
        If c.EntireRow.Hidden = False Then MyDict(CStr(c)) = 1
    Next c
    MsgBox "There are " & MyDict.Count & " unique items in the selection"
    Set MyDict = Nothing
    
End Sub

 

[nirvehex]

Oh wow, that's beautifully simple! Thanks again Eric! Nice tag line about the impossible/truth btw...

 

[Eric W]

Glad to help!

The tagline is actually a quote from one of my favorite fictional characters . . .