Here's something I put together some time ago....
'/==========================================/
Sub UniqueValues_List()
Dim dblLastRow As Double
Dim lCol As Integer, iCheckError As Integer
Dim lRow As Long, i As Long
Dim nName As name
Dim rngRange As Range
Dim strResultsTableName As String
Dim strWkbk As String
Dim strWksht As String
Dim strRange As String
Dim wkb As Workbook
Dim wkb_New As Workbook
Dim WS As Worksheet
On Error GoTo err_UniqueValues_List
strResultsTableName = "Unique_Values"
iCheckError = 0
Set rngRange = _
Application.InputBox(Prompt:="Select Range to be Searched: " & _
vbCr & vbCr & "Only ranges in CURRENT WORKSHEET may be selected", _
Title:="Range Selection...", _
Default:=Application.Selection.Address, Type:=8)
strRange = "Range: " & rngRange.Address
strWkbk = "Workbook: " & ActiveWorkbook.FullName
strWksht = "Worksheet: " & ActiveSheet.name
If Len(rngRange.Address) = 0 Then
MsgBox "No Cells were selected." & vbLf & vbLf & _
"Process Aborted.....", vbExclamation + vbOKOnly, "WARNING....."
Exit Sub
Else
rngRange.Select
End If
rngRange.Select
Set WS = ActiveSheet
Set wkb = ActiveWorkbook
'check for multiple range selections
If Selection.Areas.Count > 1 Then
MsgBox "Multiple Range selections are not supported.", _
vbExclamation + vbOKOnly, "Warning..."
End If
'check for too many cells
' because the selection will be copied to a new worksheet and
' the current version of Excel (XP) only has 65536 rows
If Selection.Cells.Count > 65536 Then
MsgBox "Sorry, your selection is to large to count unique values.", _
vbExclamation + vbOKOnly, "Warning..."
GoTo exit_UniqueValues_List
End If
If Selection.Cells.Count = 1 Then
MsgBox "You have not selected a range of cells.", _
vbExclamation + vbOKOnly, "Warning..."
GoTo exit_UniqueValues_List
End If
'Application.ScreenUpdating = False
Selection.Copy
Workbooks.Add
Sheets.Add
Sheets(1).Cells(1).PasteSpecial xlValues
lCol = Cells(1).CurrentRegion.Columns.Count
lRow = Cells(1).CurrentRegion.Rows.Count
If lCol > 1 Then
For i = 2 To lCol
Range(Cells(1, i), Cells(lRow, i)).Copy
Cells((lRow * (i - 1)) + 1, 1).PasteSpecial xlPasteValues
Range(Cells(1, i), Cells(lRow, i)).ClearContents
Next
End If
Rows("65536:65536").Delete Shift:=xlUp
ActiveSheet.UsedRange.Select
If ActiveSheet.UsedRange.Count = 1 Then
If ActiveWorkbook.name <> wkb.name Then
ActiveWorkbook.Close False
End If
wkb.Activate
MsgBox "Only Blank cells have been selected." & vbCr & _
"Process Stopped.", vbInformation + vbOKOnly, "Warning..."
GoTo exit_UniqueValues_List
End If
Selection.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"B1"), Unique:=True
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Unique Values"
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
Columns("A:A").EntireColumn.AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
ActiveSheet.Select
ActiveWorkbook.ActiveSheet.name = strResultsTableName
Set wkb_New = ActiveWorkbook
dblLastRow = _
ActiveSheet.Cells.SpecialCells(xlLastCell).Row - 1
Range("A3:A" & dblLastRow).Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveSheet.Copy after:=Workbooks(wkb.name).Sheets(WS.name)
strResultsTableName = ActiveSheet.name
Range("A1").Select
wkb_New.Activate
wkb.Activate
On Error Resume Next
'delete 'Extract' name
For Each nName In Names
If IsError(Application.WorksheetFunction.Search("Extract", _
nName.name)) Then
Else
ActiveWorkbook.Names(nName.name).Delete
End If
Next nName
On Error GoTo err_UniqueValues_List
Call MakeComment(strWkbk, strWksht, strRange)
Range("A1").Comment.Shape.Select True
Selection.ShapeRange.IncrementLeft 150
Selection.ShapeRange.IncrementTop 10
exit_UniqueValues_List:
iCheckError = 1
wkb_New.Activate
If ActiveWorkbook.name <> wkb.name Then
ActiveWorkbook.Close False
End If
wkb.Activate
'Application.ScreenUpdating = True
Set rngRange = Nothing
Set wkb = Nothing
Set wkb_New = Nothing
Set WS = Nothing
Application.Worksheets(strResultsTableName).Activate
Range("A1").Select
Application.Dialogs(xlDialogWorkbookName).Show
Exit Sub
err_UniqueValues_List:
If iCheckError = 1 Then
Exit Sub
End If
If Err.Number = 1004 Then 'Select method of Range class failed
Set wkb = ActiveWorkbook
End If
MsgBox "Selected Range(s) could not be processed." & vbCr & _
"Please try again..." & vbCr & vbCr & _
"Did you select a range that was NOT on the Current Worksheet?", _
vbCritical + vbOKOnly, "Warning..."
Resume exit_UniqueValues_List
End Sub
'/========================================/
Private Sub MakeComment(strWorkbook, strWorksheet, strRng)
'create comment
Dim dblLastRow As Double
dblLastRow = _
ActiveSheet.Cells.SpecialCells(xlLastCell).Row - 1
Range("A1").AddComment
With Range("A1").Comment
.Visible = False
.Text Text:= _
"Unique Values Count:" & dblLastRow & Chr(10) & _
strWorkbook & Chr(10) & _
strWorksheet & Chr(10) & _
strRng
.Shape.ScaleHeight 1.75, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
.Visible = True
End With
End Sub
'/=============================================/
--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown
