Multiple Modes

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.

Code:

---

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

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

Code:

---

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

---