Top 5 most recurrent values in range.

  • Thread starter Thread starter bentor
  • Start date Start date
B

bentor

Hello Everyone,

I looking for the way to get top 5 most reccurent values in range/
column and sort it descending.

For example, I've got values:

apple
dog
dog
pig
apple
flower
sweet
door
apple
apple
pink
drink
door
swim
drink

What I would like to do is get top 5:
1. Apple - 4 times
2. dog - 2 times
3. door - 2 times
4. drink - 2 times
5. flower - 1 time

If you have any ideas please let mi know.

Best regards,
Bartosz D³ugokêcki
 
Hi
If your data is in A2 to A16, in cell B2 type

= countif($A$2:$A$16,A2)

Fill this formula down. This will count the occurance of each item in
your list. Now sort using column B.
regards
Paul
 
Hi
If your data is in A2 to A16, in cell B2 type

= countif($A$2:$A$16,A2)

Fill this formula down. This will count the occurance of each item in
your list. Now sort using column B.
regards
Paul







- Pokaż cytowany tekst -
Click to expand...

In that way, you will get something like that:
apple - 4
apple - 4
apple - 4
apple - 4
dog - 2
dog - 2
door - 2
door - 2
drink - 2
drink - 2
flower - 1

Regards,
Bartosz Długokęcki
 
How about a PivotTable? You can limit it to the top 5 values and sort
descending. Drop the column header into the data field to get a count
of unique items.

--JP
 
A nice, flexible and fast way to do this is with code like this.
This presumes your list is in column A starting in A1. This needs a
reference to the free file:
dhRichClient, written by Olaf Schmidt and which can be downloaded from:
www.datenhaus.de/Downloads/dhRichClientDemo.zip
It may look complex and a lot of code, but it is fast and you don't have to
understand it.

Function MakeFrequencyArray(arrVariant As Variant, _
Optional lCols As Long = -1, _
Optional bSortDescOnCount As Boolean = True, _
Optional bSortAscOnCount As Boolean, _
Optional bSortDescOnItem As Boolean, _
Optional bSortAscOnItem As Boolean, _
Optional strFormat As String) As Variant

Dim i As Long
Dim c As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim cSD1 As cSortedDictionary
Dim cSD2 As cSortedDictionary
Dim lCount As Long
Dim lcSD1Count As Long
Dim lcSD2Count As Long
Dim arrReturn

LB = LBound(arrVariant)
UB = UBound(arrVariant)

Set cSD1 = New cSortedDictionary

If lCols = -1 Then
For i = LB To UB
If cSD1.Exists(arrVariant(i)) Then
lCount = cSD1.Item(arrVariant(i))
lCount = lCount + 1
cSD1.Item(arrVariant(i)) = lCount
Else
cSD1.Add arrVariant(i), 1
End If
Next i
Else
LB2 = LBound(arrVariant, 2)
UB2 = UBound(arrVariant, 2)
If lCols = 1 Then 'to gain some speed?
For i = LB To UB
If cSD1.Exists(arrVariant(i, LB2)) Then
lCount = cSD1.Item(arrVariant(i, LB2))
lCount = lCount + 1
cSD1.Item(arrVariant(i, LB2)) = lCount
Else
cSD1.Add arrVariant(i, LB2), 1
End If
Next i
Else
For i = LB To UB
For c = LB2 To UB2
If cSD1.Exists(arrVariant(i, c)) Then
lCount = cSD1.Item(arrVariant(i, c))
lCount = lCount + 1
cSD1.Item(arrVariant(i, c)) = lCount
Else
cSD1.Add arrVariant(i, c), 1
End If
Next c
Next i
End If
End If

If bSortDescOnCount Or bSortAscOnCount Then

Set cSD2 = New cSortedDictionary
cSD2.UniqueKeys = False

For i = 1 To cSD1.Count
cSD2.Add cSD1.ItemByIndex(i - 1), cSD1.KeyByIndex(i - 1)
Next i

lcSD2Count = cSD2.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD2Count, 1 To 4)

If Len(strFormat) > 0 Then
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = lcSD2Count - i
arrReturn(lcSD2Count - i, 2) = Format(cSD2.ItemByIndex(i),
strFormat)
'for some reason this is needed to avoid a currency sign in front
of the number
'------------------------------------------------------------------------------
arrReturn(lcSD2Count - i, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD2Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = Format(cSD2.ItemByIndex(i), strFormat)
arrReturn(i + 1, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
Else
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = lcSD2Count - i
arrReturn(lcSD2Count - i, 2) = cSD2.ItemByIndex(i)
arrReturn(lcSD2Count - i, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD2Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = cSD2.ItemByIndex(i)
arrReturn(i + 1, 3) = CLng(cSD2.KeyByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
End If

Else 'If bSortDescOnCount Or bSortAscOnCount

lcSD1Count = cSD1.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD1Count, 1 To 4)

If Len(strFormat) > 0 Then
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = lcSD1Count - i
arrReturn(lcSD1Count - i, 2) = Format(cSD1.KeyByIndex(i),
strFormat)
arrReturn(lcSD1Count - i, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD1Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = Format(cSD1.KeyByIndex(i), strFormat)
arrReturn(i + 1, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
Else
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = lcSD1Count - i
arrReturn(lcSD1Count - i, 2) = cSD1.KeyByIndex(i)
arrReturn(lcSD1Count - i, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(lcSD2Count - i, 4) = _
Format(arrReturn(lcSD1Count - i, 3) / (UB + (1 - LB)), "0.00%")
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = i + 1
arrReturn(i + 1, 2) = cSD1.KeyByIndex(i)
arrReturn(i + 1, 3) = CLng(cSD1.ItemByIndex(i))
arrReturn(i + 1, 4) = _
Format(arrReturn(i + 1, 3) / (UB + (1 - LB)), "0.00%")
Next i
End If
End If

End If 'If bSortDescOnCount Or bSortAscOnCount

MakeFrequencyArray = arrReturn

End Function


Sub test()

Dim arr
Dim arrResult

arr = Range(Cells(1), Cells(15, 1))

arrResult = MakeFrequencyArray(arr, 1)

Range(Cells(3), Cells(UBound(arrResult), UBound(arrResult, 2) + 2)) =
arrResult

End Sub



RBS



Hello Everyone,

I looking for the way to get top 5 most reccurent values in range/
column and sort it descending.

For example, I've got values:

apple
dog
dog
pig
apple
flower
sweet
door
apple
apple
pink
drink
door
swim
drink

What I would like to do is get top 5:
1. Apple - 4 times
2. dog - 2 times
3. door - 2 times
4. drink - 2 times
5. flower - 1 time

If you have any ideas please let mi know.

Best regards,
Bartosz D³ugokêcki
 
If you don't need the rank and percentage in the output then you could leave
those lines out and do:

Function MakeFrequencyArray(arrVariant As Variant, _
Optional lCols As Long = -1, _
Optional bSortDescOnCount As Boolean = True, _
Optional bSortAscOnCount As Boolean, _
Optional bSortDescOnItem As Boolean, _
Optional bSortAscOnItem As Boolean, _
Optional strFormat As String) As Variant

Dim i As Long
Dim c As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim cSD1 As cSortedDictionary
Dim cSD2 As cSortedDictionary
Dim lCount As Long
Dim lcSD1Count As Long
Dim lcSD2Count As Long
Dim arrReturn

LB = LBound(arrVariant)
UB = UBound(arrVariant)

Set cSD1 = New cSortedDictionary

If lCols = -1 Then
For i = LB To UB
If cSD1.Exists(arrVariant(i)) Then
lCount = cSD1.Item(arrVariant(i))
lCount = lCount + 1
cSD1.Item(arrVariant(i)) = lCount
Else
cSD1.Add arrVariant(i), 1
End If
Next i
Else
LB2 = LBound(arrVariant, 2)
UB2 = UBound(arrVariant, 2)
If lCols = 1 Then 'to gain some speed?
For i = LB To UB
If cSD1.Exists(arrVariant(i, LB2)) Then
lCount = cSD1.Item(arrVariant(i, LB2))
lCount = lCount + 1
cSD1.Item(arrVariant(i, LB2)) = lCount
Else
cSD1.Add arrVariant(i, LB2), 1
End If
Next i
Else
For i = LB To UB
For c = LB2 To UB2
If cSD1.Exists(arrVariant(i, c)) Then
lCount = cSD1.Item(arrVariant(i, c))
lCount = lCount + 1
cSD1.Item(arrVariant(i, c)) = lCount
Else
cSD1.Add arrVariant(i, c), 1
End If
Next c
Next i
End If
End If

If bSortDescOnCount Or bSortAscOnCount Then

Set cSD2 = New cSortedDictionary
cSD2.UniqueKeys = False

For i = 1 To cSD1.Count
cSD2.Add cSD1.ItemByIndex(i - 1), cSD1.KeyByIndex(i - 1)
Next i

lcSD2Count = cSD2.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD2Count, 1 To 2)

If Len(strFormat) > 0 Then
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = Format(cSD2.ItemByIndex(i),
strFormat)
'for some reason this is needed to avoid a currency sign in front
of the number
'------------------------------------------------------------------------------
arrReturn(lcSD2Count - i, 2) = CLng(cSD2.KeyByIndex(i))
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = Format(cSD2.ItemByIndex(i), strFormat)
arrReturn(i + 1, 2) = CLng(cSD2.KeyByIndex(i))
Next i
End If
Else
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = cSD2.ItemByIndex(i)
arrReturn(lcSD2Count - i, 2) = CLng(cSD2.KeyByIndex(i))
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = cSD2.ItemByIndex(i)
arrReturn(i + 1, 2) = CLng(cSD2.KeyByIndex(i))
Next i
End If
End If

Else 'If bSortDescOnCount Or bSortAscOnCount

lcSD1Count = cSD1.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD1Count, 1 To 2)

If Len(strFormat) > 0 Then
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = Format(cSD1.KeyByIndex(i),
strFormat)
arrReturn(lcSD1Count - i, 2) = CLng(cSD1.ItemByIndex(i))
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = Format(cSD1.KeyByIndex(i), strFormat)
arrReturn(i + 1, 2) = CLng(cSD1.ItemByIndex(i))
Next i
End If
Else
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = cSD1.KeyByIndex(i)
arrReturn(lcSD1Count - i, 2) = CLng(cSD1.ItemByIndex(i))
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = cSD1.KeyByIndex(i)
arrReturn(i + 1, 2) = CLng(cSD1.ItemByIndex(i))
Next i
End If
End If

End If 'If bSortDescOnCount Or bSortAscOnCount

MakeFrequencyArray = arrReturn

End Function


RBS
 
Here is my take on this. Briefly:
(1) the values is string type, in column A of worksheet "top5"
(2) the range is known (otherwise have to check the last row containing value)
(3) if you need to keep the original data and order, copy the value into
"top5" worksheet.
(4) I am using the Sort object
(5) Obviously, the routine can be further optimized

Private Sub GetTop5()
Dim rngSource As Range ' the source range to work with
Dim celX As Range ' looping cell variable
Dim strLast As String ' remember last value string: for counting
Dim iLastRow As Long ' remember last row: for counting

Worksheets("top5").Activate ' the worksheet to work on
Set rngSource = ActiveSheet.[A1:B15] ' the range to work with

' 1) Sort on Column A
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear ' clear the sorting fields
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange rngSource ' the range to sort on
.Header = xlNo ' NO: we don't have headers
.MatchCase = False ' NOT case-sensitive
.Orientation = xlTopToBottom ' sort by row
.SortMethod = xlPinYin ' based on sound (not strokes)
.Apply ' do the soring
End With

' 2) Count frequency
' -- the duplicated ones will get count 0, so
' when sort on the count, they will appear at the end
strLast = "" ' start with impossible value
iLastRow = 0 ' start with non-existing row
For Each celX In Intersect(rngSource, Range("A:A")) ' loop through
column A
If celX.Value = strLast Then
Cells(iLastRow, 2).Value = Cells(iLastRow, 2).Value + 1
celX.Offset(0, 1) = 0 ' the duplicate row will count as 0
Else
celX.Offset(0, 1) = 1 ' the first row of unique value
iLastRow = celX.Row ' remember this as the last row
strLast = celX.Value ' remember this as the last value
End If
Next celX

' 3) Sort on Frequency, then Value
'
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear ' clear the sorting fields
.SortFields.Add Key:=Range("B1"), Order:=xlDescending
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange rngSource ' the range to sort on
.Header = xlNo ' NO: we don't have headers
.MatchCase = False ' NOT case-sensitive
.Orientation = xlTopToBottom ' sort by row
.SortMethod = xlPinYin ' based on sound (not strokes)
.Apply ' sort it
End With

' The results will be listed in the order of
' a) the frequency (column B) in descending order
' b) for the same frequency: the value (column A) in ascending order
End Sub
 
I had to edit your code a bit to make it work:

Sub GetTop5()

Dim rngSource As Range ' the source range to work with
Dim celX As Range ' looping cell variable
Dim strLast As String ' remember last value string: for counting
Dim iLastRow As Long ' remember last row: for counting
Dim LR As Long

LR = Cells(65536, 1).End(xlUp).Row
Set rngSource = Range(Cells(1), Cells(LR, 2)) ' the range to work with

' 1) Sort on Column A
rngSource.Sort Key1:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom

' 2) Count frequency
' -- the duplicated ones will get count 0, so
' when sort on the count, they will appear at the end
For Each celX In Intersect(rngSource, Range("A:A")) ' loop through
Column A
If celX.Value = strLast Then
Cells(iLastRow, 2).Value = Cells(iLastRow, 2).Value + 1
celX.Offset(0, 1) = 0 ' the duplicate row will count as 0
Else
celX.Offset(0, 1) = 1 ' the first row of unique value
iLastRow = celX.Row ' remember this as the last row
strLast = celX.Value ' remember this as the last value
End If
Next celX

' 3) Sort on Frequency, then Value
rngSource.Sort Key1:=Range("B1"), _
Order1:=xlDescending, _
Key2:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom

' The results will be listed in the order of
' a) the frequency (column B) in descending order
' b) for the same frequency: the value (column A) in ascending order

End Sub

Now copy range range A1:A15 and paste down to row 65520 and then run the
same code and compare the speed with the code I posted.
I know that it is not relevant for small ranges but worth to bear in mind
that it can be done a lot faster.


RBS



AndrewCerritos said:
Here is my take on this. Briefly:
(1) the values is string type, in column A of worksheet "top5"
(2) the range is known (otherwise have to check the last row containing
value)
(3) if you need to keep the original data and order, copy the value into
"top5" worksheet.
(4) I am using the Sort object
(5) Obviously, the routine can be further optimized

Private Sub GetTop5()
Dim rngSource As Range ' the source range to work with
Dim celX As Range ' looping cell variable
Dim strLast As String ' remember last value string: for counting
Dim iLastRow As Long ' remember last row: for counting

Worksheets("top5").Activate ' the worksheet to work on
Set rngSource = ActiveSheet.[A1:B15] ' the range to work with

' 1) Sort on Column A
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear ' clear the sorting fields
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange rngSource ' the range to sort on
.Header = xlNo ' NO: we don't have headers
.MatchCase = False ' NOT case-sensitive
.Orientation = xlTopToBottom ' sort by row
.SortMethod = xlPinYin ' based on sound (not strokes)
.Apply ' do the soring
End With

' 2) Count frequency
' -- the duplicated ones will get count 0, so
' when sort on the count, they will appear at the end
strLast = "" ' start with impossible value
iLastRow = 0 ' start with non-existing row
For Each celX In Intersect(rngSource, Range("A:A")) ' loop through
column A
If celX.Value = strLast Then
Cells(iLastRow, 2).Value = Cells(iLastRow, 2).Value + 1
celX.Offset(0, 1) = 0 ' the duplicate row will count as 0
Else
celX.Offset(0, 1) = 1 ' the first row of unique value
iLastRow = celX.Row ' remember this as the last row
strLast = celX.Value ' remember this as the last value
End If
Next celX

' 3) Sort on Frequency, then Value
'
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear ' clear the sorting fields
.SortFields.Add Key:=Range("B1"), Order:=xlDescending
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange rngSource ' the range to sort on
.Header = xlNo ' NO: we don't have headers
.MatchCase = False ' NOT case-sensitive
.Orientation = xlTopToBottom ' sort by row
.SortMethod = xlPinYin ' based on sound (not strokes)
.Apply ' sort it
End With

' The results will be listed in the order of
' a) the frequency (column B) in descending order
' b) for the same frequency: the value (column A) in ascending
order
End Sub


RB Smissaert said:
If you don't need the rank and percentage in the output then you could
leave
those lines out and do:

Function MakeFrequencyArray(arrVariant As Variant, _
Optional lCols As Long = -1, _
Optional bSortDescOnCount As Boolean = True,
_
Optional bSortAscOnCount As Boolean, _
Optional bSortDescOnItem As Boolean, _
Optional bSortAscOnItem As Boolean, _
Optional strFormat As String) As Variant

Dim i As Long
Dim c As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim cSD1 As cSortedDictionary
Dim cSD2 As cSortedDictionary
Dim lCount As Long
Dim lcSD1Count As Long
Dim lcSD2Count As Long
Dim arrReturn

LB = LBound(arrVariant)
UB = UBound(arrVariant)

Set cSD1 = New cSortedDictionary

If lCols = -1 Then
For i = LB To UB
If cSD1.Exists(arrVariant(i)) Then
lCount = cSD1.Item(arrVariant(i))
lCount = lCount + 1
cSD1.Item(arrVariant(i)) = lCount
Else
cSD1.Add arrVariant(i), 1
End If
Next i
Else
LB2 = LBound(arrVariant, 2)
UB2 = UBound(arrVariant, 2)
If lCols = 1 Then 'to gain some speed?
For i = LB To UB
If cSD1.Exists(arrVariant(i, LB2)) Then
lCount = cSD1.Item(arrVariant(i, LB2))
lCount = lCount + 1
cSD1.Item(arrVariant(i, LB2)) = lCount
Else
cSD1.Add arrVariant(i, LB2), 1
End If
Next i
Else
For i = LB To UB
For c = LB2 To UB2
If cSD1.Exists(arrVariant(i, c)) Then
lCount = cSD1.Item(arrVariant(i, c))
lCount = lCount + 1
cSD1.Item(arrVariant(i, c)) = lCount
Else
cSD1.Add arrVariant(i, c), 1
End If
Next c
Next i
End If
End If

If bSortDescOnCount Or bSortAscOnCount Then

Set cSD2 = New cSortedDictionary
cSD2.UniqueKeys = False

For i = 1 To cSD1.Count
cSD2.Add cSD1.ItemByIndex(i - 1), cSD1.KeyByIndex(i - 1)
Next i

lcSD2Count = cSD2.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD2Count, 1 To 2)

If Len(strFormat) > 0 Then
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = Format(cSD2.ItemByIndex(i),
strFormat)
'for some reason this is needed to avoid a currency sign in
front
of the number

'------------------------------------------------------------------------------
arrReturn(lcSD2Count - i, 2) = CLng(cSD2.KeyByIndex(i))
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = Format(cSD2.ItemByIndex(i), strFormat)
arrReturn(i + 1, 2) = CLng(cSD2.KeyByIndex(i))
Next i
End If
Else
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = cSD2.ItemByIndex(i)
arrReturn(lcSD2Count - i, 2) = CLng(cSD2.KeyByIndex(i))
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = cSD2.ItemByIndex(i)
arrReturn(i + 1, 2) = CLng(cSD2.KeyByIndex(i))
Next i
End If
End If

Else 'If bSortDescOnCount Or bSortAscOnCount

lcSD1Count = cSD1.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD1Count, 1 To 2)

If Len(strFormat) > 0 Then
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = Format(cSD1.KeyByIndex(i),
strFormat)
arrReturn(lcSD1Count - i, 2) = CLng(cSD1.ItemByIndex(i))
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = Format(cSD1.KeyByIndex(i), strFormat)
arrReturn(i + 1, 2) = CLng(cSD1.ItemByIndex(i))
Next i
End If
Else
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = cSD1.KeyByIndex(i)
arrReturn(lcSD1Count - i, 2) = CLng(cSD1.ItemByIndex(i))
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = cSD1.KeyByIndex(i)
arrReturn(i + 1, 2) = CLng(cSD1.ItemByIndex(i))
Next i
End If
End If

End If 'If bSortDescOnCount Or bSortAscOnCount

MakeFrequencyArray = arrReturn

End Function


RBS
Click to expand...
Click to expand...
 
That's cool.

AC

RB Smissaert said:
I had to edit your code a bit to make it work:

Sub GetTop5()

Dim rngSource As Range ' the source range to work with
Dim celX As Range ' looping cell variable
Dim strLast As String ' remember last value string: for counting
Dim iLastRow As Long ' remember last row: for counting
Dim LR As Long

LR = Cells(65536, 1).End(xlUp).Row
Set rngSource = Range(Cells(1), Cells(LR, 2)) ' the range to work with

' 1) Sort on Column A
rngSource.Sort Key1:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom

' 2) Count frequency
' -- the duplicated ones will get count 0, so
' when sort on the count, they will appear at the end
For Each celX In Intersect(rngSource, Range("A:A")) ' loop through
Column A
If celX.Value = strLast Then
Cells(iLastRow, 2).Value = Cells(iLastRow, 2).Value + 1
celX.Offset(0, 1) = 0 ' the duplicate row will count as 0
Else
celX.Offset(0, 1) = 1 ' the first row of unique value
iLastRow = celX.Row ' remember this as the last row
strLast = celX.Value ' remember this as the last value
End If
Next celX

' 3) Sort on Frequency, then Value
rngSource.Sort Key1:=Range("B1"), _
Order1:=xlDescending, _
Key2:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom

' The results will be listed in the order of
' a) the frequency (column B) in descending order
' b) for the same frequency: the value (column A) in ascending order

End Sub

Now copy range range A1:A15 and paste down to row 65520 and then run the
same code and compare the speed with the code I posted.
I know that it is not relevant for small ranges but worth to bear in mind
that it can be done a lot faster.


RBS



AndrewCerritos said:
Here is my take on this. Briefly:
(1) the values is string type, in column A of worksheet "top5"
(2) the range is known (otherwise have to check the last row containing
value)
(3) if you need to keep the original data and order, copy the value into
"top5" worksheet.
(4) I am using the Sort object
(5) Obviously, the routine can be further optimized

Private Sub GetTop5()
Dim rngSource As Range ' the source range to work with
Dim celX As Range ' looping cell variable
Dim strLast As String ' remember last value string: for counting
Dim iLastRow As Long ' remember last row: for counting

Worksheets("top5").Activate ' the worksheet to work on
Set rngSource = ActiveSheet.[A1:B15] ' the range to work with

' 1) Sort on Column A
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear ' clear the sorting fields
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange rngSource ' the range to sort on
.Header = xlNo ' NO: we don't have headers
.MatchCase = False ' NOT case-sensitive
.Orientation = xlTopToBottom ' sort by row
.SortMethod = xlPinYin ' based on sound (not strokes)
.Apply ' do the soring
End With

' 2) Count frequency
' -- the duplicated ones will get count 0, so
' when sort on the count, they will appear at the end
strLast = "" ' start with impossible value
iLastRow = 0 ' start with non-existing row
For Each celX In Intersect(rngSource, Range("A:A")) ' loop through
column A
If celX.Value = strLast Then
Cells(iLastRow, 2).Value = Cells(iLastRow, 2).Value + 1
celX.Offset(0, 1) = 0 ' the duplicate row will count as 0
Else
celX.Offset(0, 1) = 1 ' the first row of unique value
iLastRow = celX.Row ' remember this as the last row
strLast = celX.Value ' remember this as the last value
End If
Next celX

' 3) Sort on Frequency, then Value
'
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear ' clear the sorting fields
.SortFields.Add Key:=Range("B1"), Order:=xlDescending
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SetRange rngSource ' the range to sort on
.Header = xlNo ' NO: we don't have headers
.MatchCase = False ' NOT case-sensitive
.Orientation = xlTopToBottom ' sort by row
.SortMethod = xlPinYin ' based on sound (not strokes)
.Apply ' sort it
End With

' The results will be listed in the order of
' a) the frequency (column B) in descending order
' b) for the same frequency: the value (column A) in ascending
order
End Sub


RB Smissaert said:
If you don't need the rank and percentage in the output then you could
leave
those lines out and do:

Function MakeFrequencyArray(arrVariant As Variant, _
Optional lCols As Long = -1, _
Optional bSortDescOnCount As Boolean = True,
_
Optional bSortAscOnCount As Boolean, _
Optional bSortDescOnItem As Boolean, _
Optional bSortAscOnItem As Boolean, _
Optional strFormat As String) As Variant

Dim i As Long
Dim c As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim cSD1 As cSortedDictionary
Dim cSD2 As cSortedDictionary
Dim lCount As Long
Dim lcSD1Count As Long
Dim lcSD2Count As Long
Dim arrReturn

LB = LBound(arrVariant)
UB = UBound(arrVariant)

Set cSD1 = New cSortedDictionary

If lCols = -1 Then
For i = LB To UB
If cSD1.Exists(arrVariant(i)) Then
lCount = cSD1.Item(arrVariant(i))
lCount = lCount + 1
cSD1.Item(arrVariant(i)) = lCount
Else
cSD1.Add arrVariant(i), 1
End If
Next i
Else
LB2 = LBound(arrVariant, 2)
UB2 = UBound(arrVariant, 2)
If lCols = 1 Then 'to gain some speed?
For i = LB To UB
If cSD1.Exists(arrVariant(i, LB2)) Then
lCount = cSD1.Item(arrVariant(i, LB2))
lCount = lCount + 1
cSD1.Item(arrVariant(i, LB2)) = lCount
Else
cSD1.Add arrVariant(i, LB2), 1
End If
Next i
Else
For i = LB To UB
For c = LB2 To UB2
If cSD1.Exists(arrVariant(i, c)) Then
lCount = cSD1.Item(arrVariant(i, c))
lCount = lCount + 1
cSD1.Item(arrVariant(i, c)) = lCount
Else
cSD1.Add arrVariant(i, c), 1
End If
Next c
Next i
End If
End If

If bSortDescOnCount Or bSortAscOnCount Then

Set cSD2 = New cSortedDictionary
cSD2.UniqueKeys = False

For i = 1 To cSD1.Count
cSD2.Add cSD1.ItemByIndex(i - 1), cSD1.KeyByIndex(i - 1)
Next i

lcSD2Count = cSD2.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD2Count, 1 To 2)

If Len(strFormat) > 0 Then
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = Format(cSD2.ItemByIndex(i),
strFormat)
'for some reason this is needed to avoid a currency sign in
front
of the number

'------------------------------------------------------------------------------
arrReturn(lcSD2Count - i, 2) = CLng(cSD2.KeyByIndex(i))
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = Format(cSD2.ItemByIndex(i), strFormat)
arrReturn(i + 1, 2) = CLng(cSD2.KeyByIndex(i))
Next i
End If
Else
If bSortDescOnCount Then
For i = 0 To lcSD2Count - 1
arrReturn(lcSD2Count - i, 1) = cSD2.ItemByIndex(i)
arrReturn(lcSD2Count - i, 2) = CLng(cSD2.KeyByIndex(i))
Next i
Else
For i = 0 To lcSD2Count - 1
arrReturn(i + 1, 1) = cSD2.ItemByIndex(i)
arrReturn(i + 1, 2) = CLng(cSD2.KeyByIndex(i))
Next i
End If
End If

Else 'If bSortDescOnCount Or bSortAscOnCount

lcSD1Count = cSD1.Count

'return a 1-based 2-D variant array
'----------------------------------
ReDim arrReturn(1 To lcSD1Count, 1 To 2)

If Len(strFormat) > 0 Then
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = Format(cSD1.KeyByIndex(i),
strFormat)
arrReturn(lcSD1Count - i, 2) = CLng(cSD1.ItemByIndex(i))
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = Format(cSD1.KeyByIndex(i), strFormat)
arrReturn(i + 1, 2) = CLng(cSD1.ItemByIndex(i))
Next i
End If
Else
If bSortDescOnItem Then
For i = 0 To lcSD1Count - 1
arrReturn(lcSD1Count - i, 1) = cSD1.KeyByIndex(i)
arrReturn(lcSD1Count - i, 2) = CLng(cSD1.ItemByIndex(i))
Next i
Else
For i = 0 To lcSD1Count - 1
arrReturn(i + 1, 1) = cSD1.KeyByIndex(i)
arrReturn(i + 1, 2) = CLng(cSD1.ItemByIndex(i))
Next i
End If
End If

End If 'If bSortDescOnCount Or bSortAscOnCount

MakeFrequencyArray = arrReturn

End Function


RBS


A nice, flexible and fast way to do this is with code like this.
This presumes your list is in column A starting in A1. This needs a
reference to the free file:
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Acoustics - 80Hz loss in car! 0
calculate a value on a new cell based on the list 1
Counting a range of cells with TEXT 4
search range, if exist, copy cell 2
Multiple Criteria, Count If, Sum Product to get count across range 5
Is there a way to parse multiple values in a cell and applycalculations to those cell ? 1
Your top 10 movies/films of all time 10
Multi Column Combo box Not finding correct record in Form 2

Back
Top