Excel Tool for analyzing Data Redundancy

Sub UniqueAnalysis()

'Select FIRST cell in vertical (Column) Range BEFORE running program.
'starts with the current ActiveCell, and grabs entire data set from the bottom of sheet
    '(so that gaps in the data / NULL values aren't a problem)

Dim lngRow As Long
Dim lngRows As Long

Dim wksCurr As Excel.Worksheet

    'get handle for current worksheet, find bottom row of range.
    Set wksCurr = ActiveSheet
    lngRow = wksCurr.Cells(wksCurr.Rows.Count, ActiveCell.Column()).End(xlUp).Row
    lngRows = lngRow - ActiveCell.Row + 1

    'Copy the data Range
    wksCurr.Range(ActiveCell, wksCurr.Cells(lngRow, ActiveCell.Column())).Copy

    'add new worksheet
    ActiveWorkbook.Worksheets.Add After:=wksCurr

    'paste in values
    ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    'copy and paste for unique list
    Selection.Copy ActiveSheet.Range("B2")

    'remove dupes from unique list
    ActiveSheet.Range("B2:B" & lngRows + 1).RemoveDuplicates Columns:=1, Header:=xlNo

    'enter count values
    For lngRow = 2 To Cells(Rows.Count, 2).End(xlUp).Row

        Cells(lngRow, 3).Value = WorksheetFunction.CountIf(Range("A2:A" & lngRows + 1), Cells(lngRow, 2).Value)

    Next lngRow

    'sort to bring most common to top
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("C2:C" & Cells(Rows.Count, 2).End(xlUp).Row), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers

        .SetRange Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)
        .Header = False
        .MatchCase = False
        .Orientation = xlTopToBottom

        .Apply

    End With


    'Headers and formtting
    Range("A1").Value = "All Values"
    Range("B1").Value = "Uniques"
    Range("C1").Value = "Count"
    Range("A1:C1").Font.Bold = True
    Columns("A:B").AutoFit

    'Summary Values
    Range("E1").Value = "Value Count"
    Range("E2").Value = "Unique Count"
    Range("E3").Value = "Dupe Count"
    Range("E1:E3").Font.Bold = True
    Columns("E:E").AutoFit

    'punch in Count values
    Range("F1").Formula = "=COUNTA(A:A) - 1"
    Range("F2").Formula = "=COUNTA(B:B) - 1"
    Range("F3").Formula = "=F1-F2"
    Range("F1:F3").NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"


End Sub