Sub stringSummary()

Dim wb As Workbook
Dim ws As Worksheet, wsT As Worksheet
Dim arr2, dict
Dim i%, elem As Variant, n&


Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set wsT = wb.Worksheets(3)

Application.ScreenUpdating = False

With ws
    arr2 = .Range("A1", .Cells(Rows.Count, "B").End(xlUp)).Value
End With




Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = 1
For i = 1 To UBound(arr2)
    
    
    If Not dict.Exists(arr2(i, 1)) Then
    dict.Add key:=arr2(i, 1), item:=arr2(i, 2)
    Else:
         dict.item(key) = item
    End If
    
Next i


With wsT
For Each elem In dict.Items
    n = n + 1
    .Cells(n, 2) = elem
Next
n = 0
For Each elem In dict.Keys
    n = n + 1
    .Cells(n, 1) = elem
Next
End With

Application.ScreenUpdating = True

End Sub