Sub print_unique()
Const oprange = "H1"
' Lists DISTINCT list of items on spreadsheet using columns H:I in order found in source data; Col H = Item, Col I = Frequency it appears in the source data
Dim v
v = getUniqueArray(Range("b2:b30"))
If IsArray(v) Then
Range(oprange).Resize(UBound(v), 2) = v
End If
End Sub
Sub test()
' Takes the source data and asks for the highest 10 frequent things.
' Output is shown as a text string showing: [Item Name] is in position [Order of Frequency] (i.e. Highest = 1, Second Highest = 2 and so on) with a count of [No of times found]
' IMPORTANT NOTE: Because I used a RANGE to sort the data (rather than, say, a sort routine) the GetMFOS routine this calls uses range K:L
' This can be avoided by adding a sort routine to the array and not using the range object. Additionally, this means a UDF (User Defined Function can be used!)
Const TempRange = "K1"
Const oprange = "F"
Dim OP As String
Dim FreqCntr As Integer
For FreqCntr = 1 To 10
GetMFOS Range("b2:b30"), FreqCntr, OP, TempRange
Range(oprange & FreqCntr).Value = OP
Next FreqCntr
End Sub
Sub GetMFOS(ByVal StrRange As Range, ByVal FreqSought As Integer, ByRef OutputStr As String, ByVal TempRange As String)
Dim v
Dim r As Range
v = getUniqueArray(StrRange)
If IsArray(v) Then
If FreqSought > UBound(v) Then
OutputStr = "There are only " & UBound(v) & " items. Cannot find item at position " & FreqSought
Exit Sub
End If
Set r = Range(TempRange).Resize(UBound(v), 2)
For cntr = 1 To UBound(v)
r.Cells(cntr, 1).Value = v(cntr, 1)
r.Cells(cntr, 2).Value = v(cntr, 2)
Next cntr
r.Sort Key1:=r.Cells(1, 2), order1:=xlDescending, Header:=xlNo
OutputStr = r.Cells(FreqSought, 1) & " is in position " & FreqSought & " with a count of " & r.Cells(FreqSought, 2) & " Items Found"
End If
End Sub
Public Function getUniqueArray(inputRange As Range, _
Optional skipBlanks As Boolean = True, _
Optional matchCase As Boolean = True, _
Optional prepPrint As Boolean = True _
) As Variant
Dim vDic As Object
Dim tArea As Range
Dim tArr As Variant, tVal As Variant, tmp As Variant
Dim noBlanks As Boolean
Dim cnt As Long
Dim CntArray()
On Error GoTo exitFunc:
If inputRange Is Nothing Then GoTo exitFunc
With inputRange
If .Cells.Count < 2 Then
ReDim tArr(1 To 1, 1 To 1)
tArr(1, 1) = .Value2
getUniqueArray = tArr
GoTo exitFunc
End If
Set vDic = CreateObject("scripting.dictionary")
If Not matchCase Then vDic.compareMode = vbTextCompare
noBlanks = True
For Each tArea In .Areas
tArr = tArea.Value2
For Each tVal In tArr
If tVal <> vbNullString Then
vDic.Item(tVal) = vDic.Item(tVal) + 1
If vDic.Exists(tVal) Then Debug.Print vDic(tVal)
ElseIf noBlanks Then
noBlanks = False
End If
Next
Next
End With
If Not skipBlanks Then If Not noBlanks Then vDic.Item(vbNullString) = Empty
If prepPrint Then
ReDim tmp(1 To vDic.Count, 1 To 2)
For Each tVal In vDic.Keys
cnt = cnt + 1
tmp(cnt, 1) = tVal
Next
cnt = 0
For Each tVal In vDic.items
cnt = cnt + 1
tmp(cnt, 2) = tVal
Next
getUniqueArray = tmp
End If
exitFunc:
Set vDic = Nothing
End Function
