Identify top 5 items in array

A

austin350s10

Active Member
Joined
Jul 30, 2010
Messages
321
Does anyone know a way to identify the top 5 item from inside an array? I have an array that contains string values from a range. The range is one column wide and is over 1000 rows long. I am looking for a way to use vba to identify the top 5 strings used in the range. Any ideas would be appreciated.
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
I'm going to call your array myArray() in my code. I'm going to create a new array of unique values and call it uniqueArray()
Code: 
ReDim Preserve uniqueArray(0) as Variant
uniqueArray(0) = myArray(0)
a = 1
For Each item in myArray
    itExists = FALSE
    For Each element in uniqueArray
        If item = element Then
            itExists = TRUE
        End If
    Next element
    If itExists = FALSE Then
        ReDim Preserve uniqueArray(a) as Variant
        uniqueArray(a) = item
        a = a + 1
    End If
Next item

a = 0
For Each element in uniqueArray
    ReDim Preserve arrayCounter(a) as Variant
    arrayCounter(a) = 0
    a = a + 1
Next element

a = 0
For Each element in uniqueArray
    For Each item in myArray
        If element = item Then
            counterArray(a) = counterArray(a) + 1
        End If
    Next item
    a = a + 1
Next element

a = 0
Top1 = ""
Top2 = ""
Top3 = ""
Top4 = "'
Top5 = ""
For Each thingy in uniqueArray
    If counterArray(a) > Top1 Then
        Top5 = Top4
        Top4 = Top3
        Top3 = Top2
        Top2 = Top1
        Top1 = thingy
    EndIf counterArray(a) > Top2 Then
        Top5 = Top4
        Top4 = Top3
        Top3 = Top2
        Top2 = thingy
    ElseIf counterArray(a) > Top3 Then
        Top5 = Top4
        Top4 = Top3
        Top3 = thingy
    ElseIf counterArray(a) > Top4 Then
        Top5 = Top4
        Top4 = thingy
    ElseIf counterArray(a) > Top5 Then
        Top5 = thingy
    End If
Next thingy
Top1 will equal the value with the highest number of occurances in your array aka myArray(). Top5 will equal the value with the 5th highest number of occurances in your array aka myArray(). Any questions?
 
Last edited:
Upvote 0
WarPiglet that seems like it should work. Unfortunately, your code throws an error on the 1st line:

Code: 
ReDim Preserve uniqueArray(0) as Variant

Can you post a full sub? I tried declaring the array you use and that still does not seems to work correctly....
 
Upvote 0
I just googled ReDim Preserve and I think you need to split that into 2 lines of code.
Code: 
Dim uniqueArray() as Variant
'OR TRY
'Dim uniqueArray as Variant
ReDim Preserve uniqueArray(0)
You only need to Dim it once. Everywhere I have ReDim code, you need to remove the "as Variant" part.

Also I just noticed that I forgot a line of code. See the last line of code that says "Next thingy"? right above it put a = a + 1
Code: 
a = a + 1
Next thingy
 
Last edited:
Upvote 0
so the following code runs without errors when using a 1D array but does not show anything for results. As soon as I switch to a 2D array i.e. a Range it errors right away. Any ideas? Can you test it on a range and see if you can get it to work?

Code: 
Sub testTop5()
Dim uniqueArray, arrayCounter, counterArray As Variant

myArray = Worksheets("MarketingData").Range("D2:D1046")

uniqueArray = Array()
arrayCounter = Array()
counterArray = Array()

ReDim Preserve uniqueArray(0) As Variant
uniqueArray(0) = myArray(0)
a = 1
For Each Item In myArray
    itExists = False
    For Each element In uniqueArray
        If Item = element Then
            itExists = True
        End If
    Next element
    If itExists = False Then
        ReDim Preserve uniqueArray(a) As Variant
        uniqueArray(a) = Item
        a = a + 1
    End If
Next Item

a = 0
For Each element In uniqueArray
    ReDim Preserve arrayCounter(a) As Variant
    arrayCounter(a) = 0
    a = a + 1
Next element

a = 0
For Each element In uniqueArray
    For Each Item In myArray
        If element = Item Then
            ReDim Preserve counterArray(a) As Variant
            counterArray(a) = counterArray(a) + 1
        End If
    Next Item
    a = a + 1
Next element

a = 0
Top1 = ""
Top2 = ""
Top3 = ""
Top4 = ""
Top5 = ""
For Each thingy In uniqueArray
    If counterArray(a) > Top1 Then
        Top5 = Top4
        Top4 = Top3
        Top3 = Top2
        Top2 = Top1
        Top1 = thingy
    ElseIf counterArray(a) > Top2 Then
        Top5 = Top4
        Top4 = Top3
        Top3 = Top2
        Top2 = thingy
    ElseIf counterArray(a) > Top3 Then
        Top5 = Top4
        Top4 = Top3
        Top3 = thingy
    ElseIf counterArray(a) > Top4 Then
        Top5 = Top4
        Top4 = thingy
    ElseIf counterArray(a) > Top5 Then
        Top5 = thingy
    End If
Next thingy

MsgBox Top1 & " " & Top2
End Sub
 
Upvote 0
I have never used a 2D array before. Also I don't even see a 2D array where you posted the code. But more importantly, I already see some problems with the code you posted. I'll test it in a little bit. I'm not on my computer. check back in 30 minutes.
 
Upvote 0
Thanks a ton! so when you assign a Range to an array it is created as a 2D array in this line:
Code: 
myArray = Worksheets("MarketingData").Range("D2:D1046")
instead of a standard 1D array like:
Code: 
myArray = Array("some", "something", "some", "some2")

I really think your on to something here. I would absolutely love it if you could help me figure out how to make this work on a Range of cells. Heading out till tomorrow round 9:00am est. Thanks Again!
 
Upvote 0
Here is the DataSet I used
D
1
2hello
3hello
4hi
5word
6word
7word
8hi
9hello
10cool
11nama
12nama
13nama
14nama
15nama

<tbody>
</tbody>

The output should be nama as the first value because it has the most cells with that value in it. Here is the output in order in a messagebox.
1st: nama
2nd: hello
3rd: word
4th: hi
5th: cool

Code: 
Sub myMacro()
    master = "MarketingData"
    Dim myArray() As Variant
    Dim uniqueArray() As Variant
    Dim counterArray() As Integer

    lastRow = Sheets(master).Range("D" & Rows.Count).End(xlUp).Row
    i = 2
    a = 0
    Do Until i > lastRow
        If Sheets(master).Range("D" & i).Value <> "" Then
            ReDim Preserve myArray(a)
            myArray(a) = Sheets(master).Range("D" & i).Value
            a = a + 1
        End If
        i = i + 1
    Loop

    ReDim Preserve uniqueArray(0)
    uniqueArray(0) = myArray(0)
    a = 1
    For Each Item In myArray
        itExists = False
        For Each element In uniqueArray
            If Item = element Then
                itExists = True
            End If
        Next element
        If itExists = False Then
            ReDim Preserve uniqueArray(a)
            uniqueArray(a) = Item
            a = a + 1
        End If
    Next Item

    a = 0
    For Each element In uniqueArray
        ReDim Preserve counterArray(a)
        counterArray(a) = 0
        a = a + 1
    Next element

    a = 0
    For Each element In uniqueArray
        For Each Item In myArray
            If element = Item Then
                counterArray(a) = counterArray(a) + 1
            End If
        Next Item
        a = a + 1
    Next element

    a = 0
    Top1 = 0
    Top2 = 0
    Top3 = 0
    Top4 = 0
    Top5 = 0
    For Each thingy In uniqueArray
        If counterArray(a) > Top1 Then
            Top5 = Top4
            Top4 = Top3
            Top3 = Top2
            Top2 = Top1
            Top1 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = Top3Value
            Top3Value = Top2Value
            Top2Value = Top1Value
            Top1Value = thingy
        ElseIf counterArray(a) > Top2 Then
            Top5 = Top4
            Top4 = Top3
            Top3 = Top2
            Top2 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = Top3Value
            Top3Value = Top2Value
            Top2Value = thingy
        ElseIf counterArray(a) > Top3 Then
            Top5 = Top4
            Top4 = Top3
            Top3 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = Top3Value
            Top3Value = thingy
        ElseIf counterArray(a) > Top4 Then
            Top5 = Top4
            Top4 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = thingy
        ElseIf counterArray(a) > Top5 Then
            Top5 = counterArray(a)
            Top5Value = thingy
        End If
        a = a + 1
    Next thingy
    MsgBox "1st:  " & Top1Value & vbNewLine & _
        "2nd:  " & Top2Value & vbNewLine & _
        "3rd:  " & Top3Value & vbNewLine & _
        "4th:  " & Top4Value & vbNewLine & _
        "5th:  " & Top5Value & vbNewLine
End Sub
I know my code isn't very elegant towards the end, but it works. I haven't learned how to incorporate a 2D array into my code yet so I had to use variables Top1 and Top1Value to accomplish the same thing that a 2D array would have done.
 
Last edited:
Upvote 0
Dude you rock....I have been working so long on trying to figure this out! I'm sure there is a prettier way to do it but looks like neither of us understand how to. I just made a couple tweaks to your code to make in into a function that you can pass an array to and output an array:

Code: 
Function Top5(myArray As Variant) As Variant 'accepts an array to look at and returns an array
    Dim uniqueArray() As Variant
    Dim counterArray() As Integer

    uniqueArray = Array()
    a = 1
    For Each Item In myArray
        itExists = False
        For Each element In uniqueArray
            If Item = element Then
                itExists = True
            End If
        Next element
        If itExists = False Then
            ReDim Preserve uniqueArray(a)
            uniqueArray(a) = Item
            a = a + 1
        End If
    Next Item

    For x = LBound(uniqueArray) To UBound(uniqueArray)
        ReDim Preserve counterArray(x)
        counterArray(x) = 0
    Next

    a = 0
    For Each element In uniqueArray
        For Each Item In myArray
            If element = Item Then
                counterArray(a) = counterArray(a) + 1
            End If
        Next Item
        a = a + 1
    Next element

    a = 0
    Top1 = 0
    Top2 = 0
    Top3 = 0
    Top4 = 0
    Top5 = 0
    For Each thingy In uniqueArray
        If counterArray(a) > Top1 Then
            Top5 = Top4
            Top4 = Top3
            Top3 = Top2
            Top2 = Top1
            Top1 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = Top3Value
            Top3Value = Top2Value
            Top2Value = Top1Value
            Top1Value = thingy
        ElseIf counterArray(a) > Top2 Then
            Top5 = Top4
            Top4 = Top3
            Top3 = Top2
            Top2 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = Top3Value
            Top3Value = Top2Value
            Top2Value = thingy
        ElseIf counterArray(a) > Top3 Then
            Top5 = Top4
            Top4 = Top3
            Top3 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = Top3Value
            Top3Value = thingy
        ElseIf counterArray(a) > Top4 Then
            Top5 = Top4
            Top4 = counterArray(a)
            Top5Value = Top4Value
            Top4Value = thingy
        ElseIf counterArray(a) > Top5 Then
            Top5 = counterArray(a)
            Top5Value = thingy
        End If
        a = a + 1
    Next thingy
    Top5 = Array(Top1Value, Top2Value, Top3Value, Top4Value, Top5Value) ' store results in array
End Function

Call it with:
Code: 
Sub myCall()
Dim myArrayOfValues() As Variant
myArrayOfValues = Array("val1", "val1", "val2") 'whatever you want in here

myOutput = Top5(myArrayOfValues) ' pass array of values to be looked at to Top 5 function
    MsgBox myOutput(0) & " " & myOutput(1) & " " & myOutput(2) & " " & myOutput(3) & " " & myOutput(4) ' output the results from Top5 function
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Match cell contents exactly for find and replace based on a table
Replies
3
Views
130
mumps
mumps
I
  • Question
CountIF alternative for performance improvements
2 3
Replies
21
Views
429
ItalianPlatinum
I
F
  • Question
Filtering/Copying a table via VBA.
Replies
2
Views
182
frobeniusabnorm
F
A
  • Question
Dynamically add new rows via VBA when using IFERROR TEXTJOIN and FILTER formulas from Table?
Replies
0
Views
184
AlfredDB
A
H
  • Solved
Range.Formula does not lead to cell "selected" or "active"
Replies
5
Views
135
heathball
H

Forum statistics

Threads
1,216,069
Messages
6,128,599
Members
449,460
Latest member
jgharbawi

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top