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