Another method might be:
Sub CountNames()
Dim nme As String, nmCol As New Collection, rCell As Range, var As Variant
Dim FinalCol As New Collection, NR As Long, x As Long, nm
With Worksheets(" AS IS")
For Each rCell In .Range("V1:V" & .Range("V" & Rows.Count).End(xlUp).Row).Cells
var = Split(rCell.Value, ", ")
For x = 0 To UBound(var)
On Error Resume Next
nmCol.Add var(x), CStr(var(x))
On Error GoTo 0
Next x
Next rCell
.Columns("V:V").Replace What:=", ", Replacement:=","
.Columns("V:V").TextToColumns Destination:=Range("V1"), DataType:=xlDelimited, Other:=True, OtherChar:=",", TrailingMinusNumbers:=True
For Each nm In nmCol
FinalCol.Add nm & "|" & Application.CountIf(.Cells, nm), CStr(nm)
Next
End With
With Worksheets("Sheet1")
For Each nm In FinalCol
NR = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & NR) = Split(nm, "|")(0)
.Range("B" & NR) = Split(Split(nm, "|")(0), " ")(1)
.Range("C" & NR) = Split(nm, "|")(1)
Next nm
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange .Range("A1:C" & .Range("A" & Rows.Count).End(xlUp).Row)
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
End Sub
This version modifies the raw data, the prvious one does not touch it.
Bookmarks