Hello shuynh84,
The macro has been updated to add the sheet "Count". If the sheet already exists then it will be cleared when the macro runs.
It has been added to the attached workbook.
Revised Macro
Sub Macro1()
Dim DataIn As Variant
Dim DataOut As Variant
Dim Dict As Object
Dim Item As Variant
Dim Key As Variant
Dim n As Long
Dim Rng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("Summary")
Set Rng = Wks.Range("A1").CurrentRegion
Set Rng = Intersect(Rng, Rng.Offset(1, 1))
Header = Wks.Range("A1", Wks.Cells(1, Columns.Count).End(xlToLeft)).Value
DataIn = Rng.Value
ReDim DataOut(Rng.Cells.Count - 1, 0)
On Error Resume Next
Set Wks = Worksheets("Count")
If Err <> 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Count"
Set Wks = ActiveSheet
Wks.Range("A1").Value = "Description"
Else
Wks.UsedRange.Offset(1, 0).ClearContents
End If
On Error Resume Next
Set Rng = Wks.Range("A2")
For Each Item In DataIn
DataOut(n, 0) = Item
n = n + 1
Next Item
Set Rng = Rng.Resize(n, 1)
Rng.Value = DataOut
Wks.Sort.SortFields.Clear
Wks.Sort.SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, Order:=xlAscending
With Wks.Sort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SetRange Rng
.Apply
End With
DataOut = Rng.Value
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextComapre
For Each Item In DataOut
Key = Trim(Item)
If Key <> "" Then
If Not Dict.Exists(Key) Then
Dict.Add Key, 1
Else
Item = Dict(Key)
Dict(Key) = Item + 1
End If
End If
Next Item
n = 0
For Each Key In Dict.Keys
Rng.Offset(n, 1).Resize(1, 2).Value = Array(Key, Dict(Key))
n = n + 1
Next Key
End Sub
Bookmarks