PDA

View Full Version : Multiple Modes



zoom38
11-14-2016, 10:11 AM
Hello I am trying to create a sub that will choose the value (strings or numbers) from a set or range of values that occur most often (mode) and then the next value that occurs most often until there are values left that only occur once. Once that is done I would like to randomly pick a value from the remaining values that have not already been chosen.

I have found the following multiple mode function while searching the net and like it very much. However I am trying to modify it so that if there are multiple modes, the values will be in different columns instead of the same cell but I can't figure out how to separate them. I tried changing it to a sub but was unsuccessful to get it to work correctly.



Function moder(x As Range)
Dim modes As New Collection

For Each ce In x
If WorksheetFunction.CountIf(x, ce) = _
WorksheetFunction.CountIf(x, WorksheetFunction.Mode(x)) Then
On Error Resume Next
modes.Add Item:=ce, Key:=Str(ce)
End If
Next

For i = 1 To modes.count
moder = moder & "," & modes(i)
Next i
moder = WorksheetFunction.Substitute(moder, ",", "", 1)
End Function

Any assistance would be appreciated. I'm using Excel 2007.

Thanks
Gary

Paul_Hossler
11-14-2016, 11:57 AM
Not too sure that that Function will get you where you want

No details on where you wanted the values by columns so I just started in row 1 col 5




Option Explicit

Sub drv()
GetModes (ActiveSheet.Range("A1:A40"))
End Sub

Sub GetModes(x As Range)
Dim cUniques As Collection
Dim rCell As Range
Dim i As Long, j As Long, n As Long
Dim aUniques() As Variant, aCounts() As Long
Dim vU As Variant, vC As Variant

Set cUniques = New Collection

'build list of uniques
For Each rCell In x.Cells
On Error Resume Next
cUniques.Add rCell.Value, rCell.Text
On Error GoTo 0
Next

'create working arrays
ReDim aUniques(1 To cUniques.Count)
ReDim aCounts(1 To cUniques.Count)

'for each unique, find number of occurances
For i = 1 To cUniques.Count
aUniques(i) = cUniques(i)
aCounts(i) = Application.WorksheetFunction.CountIf(x, aUniques(i))
Next

'bubble sort ot have counts high to low
For i = 1 To UBound(aCounts) - 1
For j = i To UBound(aCounts)
If aCounts(i) < aCounts(j) Then
vU = aUniques(j)
aUniques(j) = aUniques(i)
aUniques(i) = vU

vC = aCounts(j)
aCounts(j) = aCounts(i)
aCounts(i) = vC
End If
Next j
Next i

'do columns, starting in E for demo
For i = LBound(aCounts) To UBound(aCounts)
If aCounts(i) > 1 Then
ActiveSheet.Cells(1, 4 + i).Value = aUniques(i)
ActiveSheet.Cells(2, 4 + i).Value = aCounts(i)

Else
n = Application.WorksheetFunction.RandBetween(i, UBound(aCounts))
ActiveSheet.Cells(1, 4 + i).Value = aUniques(n)
ActiveSheet.Cells(2, 4 + i).Value = aCounts(n)
Exit For
End If
Next i
End Sub