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
Code: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
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.
Have a lovley day and I will work this as solved!Code: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
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.
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
Code: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