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