VBA excel finding the statistical mode of a collection - vba

Question

So I'm trying to analysis some data in Excel and having some trouble finding the most frequent numbers. I have an unknown number of locations which can have an unknown number of donations. For example
Brantford $50.00
Brantford $25.00
Brantford $50.00
Windsor $200.00
Quebec $25.00
Quebec $100.00
Quebec $50.00
Quebec $50.00
Quebec $25.00
Quebec $50.00
Quebec $50.00
Quebec $25.00
Quebec $100.00
Quebec $40.00
Windsor $140.00
Windsor $20.00
Windsor $20.00
So I need to use VBA to find for each location the count, sum, mean and mode (has to be done through VBA, can't just write instructions on how to do this using advanced filters/pivot tables :().
So right now using VBA I have a dictionary object that stores the location name as a key and each donation in a collection. Using the count of the collection I have the count, can easily loop through the collection for the sum, using those I have the mean; but, I am not sure the most efficient way to get the mode.
I know I can find it if my data was in an array using Application.mode, but that doesn't appear to work for collections :(. Converting a collection to an array though to find the mode though really doesn't strike me as the most efficient solution. Only other option i can find of though is to sort the collections then loop through them to find the mode.
So wondering if anyone knows of a good way to find the statistical mode of a collection?
Dim locdata As Object
Set locdata = CreateObject("scripting.dictionary")
For counter = 2 To max
mykey = Cells(counter, loccol).value
If Not (locdata.exists(mykey)) Then
locdata.Add (mykey), New Collection
End If
locdata(mykey).Add (Cells(counter, donamountcol).value)
Next counter
For Each k In locdata.keys
locname = k
Cells(counter, 1) = k
Cells(counter, 2) = locdata(k).Count
donationtotal = 0
For Each donvalue In locdata(k)
donationtotal = donationtotal + donvalue
Next donvalue
Cells(counter, 3) = donationtotal
Cells(counter, 4) = donationtotal / CDbl(locdata(k).Count)
'Cells(counter, 5) = Application.mode(locdata(k)) doesn't work :(
counter = counter + 1
Next k
edit: Ideally the output should be (using Quebec as an example)
Quebec: Count: 10 Sum: 515 Average: 51.5 Mode: 50

Answer 1

Here is how you can have values in a range into aarray dynamically. And I would use CountIF in the VBA to find the most frequent objects by their names.. Since you don't know the location names or the donations. Then array is the way to go.
Dim ar as Variant
Dim endRow as Long
'get last row in the range
endRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row
'ar = WorksheetFunction.Transpose(Shets(1).Range("A1:A12")
'using endrow
ar = WorksheetFunction.Transpose(Shets(1).Range("A1").resize(endRow).value)
UPDATE: The subroutine below uses one iteration (for loop) to find the Mode..
Sub FrequencyByLocDonations()
Dim ar As Variant, dc As Object
Dim rngInput As Range, mxRng As Range
Dim endRow As Long, i As Integer
Dim counts As Double, maxLoc As Double
Dim maxLocation As String
Set dc = CreateObject("Scripting.Dictionary")
'-- When you know the range
' ar = WorksheetFunction.Transpose(Shets(1).Range("A1:A12").Value
'get last row in the range when you don't know but the starting cell
endRow = Sheets(3).Cells(Sheets(3).Rows.Count, "C").End(xlUp).Row
Set rngInput = Sheets(3).Range("C2").Resize(endRow - 1, 1)
'--you may also use that set rngInput as well
' WorksheetFunction.Transpose(rngInput).Value
'-- using endrow-1 to not to take an extra blank row at the end
ar = WorksheetFunction.Transpose(Sheets(3).Range("C2").Resize(endRow - 1, 2).Value)
For i = LBound(ar, 2) To UBound(ar, 2)
If Not (dc.exists(ar(1, i))) Then
counts = Application.WorksheetFunction.CountIf(rngInput, ar(1, i))
If counts >= maxLoc Then
maxLocation = ar(1, i)
maxLoc = counts
End If
dc.Add ar(1, i), counts
End If
Next i
'-- output to the Sheet
Sheets(3).Range("C2").Offset(0, 2).Resize(UBound(dc.keys) + 1, 1) = _
Application.Transpose(dc.keys)
Sheets(3).Range("C2").Offset(0, 3).Resize(UBound(dc.items) + 1, 1) = _
Application.Transpose(dc.items)
Sheets(3).Range("C2").Offset(0, 4) = "Most Frequent Location :" _
& maxLocation & "; " & maxLoc
Set dc = Nothing
End Sub
output:

Answer 2

I have run into a similar situation in the past. It seemed to me there was a very powerful VBA function missing from excel - equivalent to the "where" statement in MySQL.
So I wrote a very simple one myself... This lacks a lot of functionality, but it will allow you to do what you are asking for, while minimizing the amount of code you write.
Fundamental concept: you can return an array from a function call, and Excel built-in functions can operate on such an array as they would on a function. Thus, if you have a function that returns "all the numbers of which I want the mode", then =MODE(myfunction()) will give you the answer you want.
I chose to call my function subset(criteria, range1, range2).
In its most simple form it returns the elements in range2 that correspond to elements in range1 that meet criteria.
This is NOT extensively tested, but I hope you get the idea.
By the way, you can enter this as an array formula (shift-ctrl-enter) in multiple cells; in that case you get the first returned element in the first cell, etc. Sometimes that's a useful trick when you have a function that needs to return more than one value (e.g. a range) - but for this case you only need the result to feed to another function.
Option Explicit
' Function subset(criteria, range1, range2)
' Return an array with the elements in range2 that correspond to
' elements in range1 that match "criteria"
' where "criteria" can be a string, or a value with a < = > sign in front of it
' example: =subset("bravo", A1:A10, B1:B10)
' returns all cells from B that corresponds to cells in A with "bravo"
' =subset("<10", A1:A10, B1:B10) returns all cells in B corresponding to
' cells in A with a value < 10
' This is analogous to the "where" function in SQL, but much more primitive
Function subset(criteria As String, range1 As Range, range2 As Range)
Dim c
Dim result
Dim ii, jj As Integer
On Error GoTo etrap
If range1.Cells.Count <> range2.Cells.Count Then Exit Function
ReDim result(1 To range1.Cells.Count)
ii = 1
jj = 1
For Each c In range1.Cells
If compare(c.Value, criteria) = 0 Then
result(ii) = range2.Cells(jj).Value
ii = ii + 1
End If
jj = jj + 1
Next c
If ii > 1 Then
ReDim Preserve result(1 To ii - 1)
subset = result
Else
subset = Nothing
End If
Exit Function
etrap:
MsgBox "Error " & Err.Description
End Function
Private Function compare(a, b)
' type of a decides what kind of comparison we do
If TypeName(a) <> TypeName("hello") Then
' use numerical comparison
compare = Not (Evaluate(a & b))
Else
' use string comparison
compare = StrComp(a, b, vbTextCompare)
End If
End Function

Answer 3

I actually just decided to make a dictionary of dictionaries. So I have the locations and each location than has a dictionary of the count of each donation amount. Was easy enough to compare counts that way to find the mode.