Option Base 1
Option Explicit
Option Private Module
'====================================================================================================
Sub PRDX_DuplReport()
Dim dic As New Dictionary
Dim rng As Range, aDic(), aOne(1, 1)
Dim arr, v$, txCol$, t!, a&, r&, rr&, c&, n&, d&, fR&, fC&, VT&, AC&

t = Timer
Set rng = Selection: If rng.Cells.Count = 1 Then Set rng = ActiveSheet.UsedRange Else Set rng = Intersect(rng, ActiveSheet.UsedRange)
If rng.Cells.Count = 1 Then MsgBox "There is Only ONE Cell on a WorkSheet", vbInformation, "DuplReport": Exit Sub
ReDim aDic(rng.Cells.Count, 3) ' Arr2D: StrValue, Address, Count

For a = 1 To rng.Areas.Count
    With rng.Areas(a).Cells(1, 1): fR = .Row - 1: fC = .Column - 1: End With
    arr = rng.Areas(a).Value: If Not IsArray(arr) Then aOne(1, 1) = arr: arr = aOne

    For c = 1 To UBound(arr, 2)
        txCol = PRDX_RngColConvert_NumToLtr(fC + c)
        For r = 1 To UBound(arr, 1)
            VT = VarType(arr(r, c)): If VT < 2 Then GoTo nx Else If VT > 8 Then GoTo nx Else If Len(arr(r, c)) = 0 Then GoTo nx
            n = n + 1: v = arr(r, c)
            Select Case dic.Exists(v)
                Case True: rr = dic(v): aDic(rr, 2) = aDic(rr, 2) & "," & txCol & fR + r:   aDic(rr, 3) = aDic(rr, 3) + 1
                Case Else: d = d + 1:   aDic(d, 2) = txCol & fR + r:                        aDic(d, 3) = 1:                 aDic(d, 1) = v: dic.Add v, d
            End Select
nx:     Next r
    Next c
Next a

If d = 0 Then MsgBox "There is NO any current Values!", vbExclamation, Format$(Timer - t, "0.00 sec"): Exit Sub
If d = 1 Then MsgBox "There is only ONE Uniq Value!", vbExclamation, Format$(Timer - t, "0.00 sec"): Exit Sub

Application.ScreenUpdating = False
AC = Application.Calculation: Application.Calculation = xlCalculationManual

    Worksheets.Add After:=ActiveSheet
    Columns(1).NumberFormat = "@"
    Cells(1, 1).Resize(1, UBound(aDic, 2)).Value2 = Array("StrValue", "Addresses", "Count")
    Cells(2, 1).Resize(d, UBound(aDic, 2)).Value = aDic

Application.ScreenUpdating = True
Application.Calculation = AC

MsgBox "UniqList (" & Format$(d, "#,##0") & ") of Values (" & Format$(n, "#,##0") & ") was created!", vbInformation, Format$(Timer - t, "0.00 sec")
End Sub
'====================================================================================================
Function PRDX_RngColConvert_NumToLtr(ByVal nCol&) As String
Dim ch&, i&
Static a(16384) As String, fStatic As Boolean

    If Not fStatic Then
        fStatic = True

        For ch = 65 To 90
            i = i + 1: a(i) = Chr$(ch)
        Next ch
        For i = 27 To 16384
            a(i) = ColToLtr(i)
        Next i
    End If
PRDX_RngColConvert_NumToLtr = a(nCol)
End Function
'----------------------------------------------------------------------------------------------------
Private Function ColToLtr(nCol&) As String
Dim cQUO As Long, cMOD As Long, cQUO2 As Long, cMOD2 As Long
    If nCol <= 702 Then
        cQUO = nCol \ 26
        cMOD = nCol Mod 26
        If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
        ColToLtr = Chr$(cQUO + 64) & Chr$(cMOD + 64)
    Else
        cQUO = nCol \ 26
        cMOD = nCol Mod 26
        cQUO2 = (nCol - 26) \ 676
        cMOD2 = (nCol - 26) Mod 676
        If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
        If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
        ColToLtr = Chr$(cQUO2 + 64) & Chr$((cQUO - cQUO2 * 26) + 64) & Chr$(cMOD + 64)
    End If
End Function
'====================================================================================================