picking up every new unique name and counting the times it appears in a column (VBA)

[markpem]

Hello

Can anyone help me out with some vba code? I think I may need an array but a little unsure on the best way to go about it.

In column A I have a list of peoples surnames

example:-
jones
smith
patel
jones
jones
grey
patel
chu
jones

I need the script to generate something like this (into a string? or even into a spare worksheet) - picking up every new unique name and counting the times it appears in a column

jones 4
smith 1
grey 1
patel 2
chu 1

Would anyone be able to help?

thanks

Mark

[Kenneth Hobs]

Sub Main()  
  Dim n As Range, su() As Variant, i As Long, s As String
  Set n = Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown))
  su() = ArrayListSort(WorksheetFunction.Transpose(n))
  su() = UniqueArrayByDict(su)
  'MsgBox Join(su, vbLf)
  For i = 0 To UBound(su)
    s = "=CountIf(" & n.Address(External:=True) & "," & """" & su(i) & """" & ")"
    su(i) = su(i) & " " & Evaluate(s)
  Next i
  
  s = Join(su(), vbLf)
  MsgBox s
End Sub


'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
  'Dim dic As Object 'Late Binding method - Requires no Reference
  'Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  Dim dic As Dictionary     'Early Binding method
  Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function


Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True) As Variant
    With CreateObject("System.Collections.ArrayList")
        Dim cl As Variant, i As Long
        For i = LBound(sn) To UBound(sn)
            .Add sn(i)
        Next
         
        .Sort 'Sort ascendending
        If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
        ArrayListSort = .toarray()
    End With
End Function

[markpem]

Hello Kenneth Hobs

THANKYOU very much for your code. I realize that you have taken your own time to do this and for that it's very much appreciated >> all the karma to you <<<

The code works amazing, I have to make a small change by commenting out some of the code and including the other bits but it worked exactly how I expected.

    Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
    'Dim dic As Dictionary 'Early Binding method
    'Set dic = New Dictionary 'Early Binding Method
    Dim e As Variant

Have a lovley day and I will work this as solved!

[Kenneth Hobs]

Right, you could have added the reference as I commented by the Tools > References or use the late bound method which I also commented and you chose.

[markpem]

Hello,

I hope I am not being too cheeky by asking for a bit more help - Kenneth your code did what I wanted (and works amazing), however I wondered if Kenneth or anyone may be able to make an adjustment?

Is it possible for the array to count two columns? and arrange the data? For example:-


In column A I have a list of peoples surnames and in Column B i have for example Accepted/Rejected
example:-
Column A Column B
jones Accepted
smith Rejected
patel Rejected
jones Accepted
jones Rejected
grey Rejected
patel Rejected
chu Rejected
jones Rejected

and it would generate something like this: (if it can sort by column A alphabetically then great but not a huge deal)

Jones - Accepted 2
Smith - Rejected 1
Patel - Rejected 2
Jones - Rejected 1
Grey - Rejected 1
Patel - Rejected 1
Chu - Rejected 1

Thank you for all your time.

Mark

[snb]

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
 
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn)
      .Item(sn(j, 1) & "_" & sn(j, 2)) = .Item(sn(j, 1) & "_" & sn(j, 2)) + 1
    Next

    sn = Application.Transpose(Array(.keys, .items))
  End With
 
  For j = 1 To UBound(sn)
    sn(j, 2) = Split(sn(j, 1), "_")(1) & " " & sn(j, 2)
    sn(j, 1) = Split(sn(j, 1), "_")(0)
  Next
  
  sheet1.Cells(1, 6).Resize(UBound(sn), 2) = sn
  sheet1.Cells(1, 6).CurrentRegion.Sort sheet1.Cells(1, 6)
End Sub