Hi,
You cant do it with Pivot Tables..
Try this
Sub GetCountOfNamesOptimised()
Dim Cell As Range, Counter As Integer, NewArr(), I As Integer
With CreateObject("Scripting.Dictionary")
For Each Cell In Range("A1").CurrentRegion.Offset(1, 1)
If Not .Exists(Cell.Value) And Cell.Value <> "" Then .Add Cell.Value, Application.CountIfs(Range("A1").CurrentRegion, Cell.Value)
Next Cell
For Counter = 0 To .Count - 1
If Not IsEmpty(.Keys()(Counter)) Then
ReDim Preserve NewArr(1, I): NewArr(0, I) = .Keys()(Counter): NewArr(1, I) = .Item(.Keys()(Counter)): I = I + 1
End If
Next Counter
End With
Cells(Cells(Rows.Count, 1).End(xlUp).Row + 2, 1).Resize(UBound(NewArr, 2) + 1, 2).Value = Application.Transpose(NewArr)
End Sub
I am unable to attach a sample file for some reason. Let me know If you have any issues.
Bookmarks