No experience, special copy and paste column macro

Hello shuynh84,

This should be close to what you want. A new sheet "Result" has been added along with a button to run the macro.

The sorted results are in column "A" while columns "B" and "C" display the unique entries and their counts.

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))
        
            DataIn = Rng.Value
            
            ReDim DataOut(Rng.Cells.Count - 1, 0)
            
                Set Rng = Worksheets("Result").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
            
                Set Wks = Rng.Parent
            
                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