Conditional top 10 Modes

[smit3446]

I have a dataset of 100,000+ rows of claim values. I'm trying to find the top 10 modes for each state and print them on a subsequent tab with the value of the mode and frequency count. Here's some dummy data:

Sequence Number	State	Original Year	Sum of Total Payment
1343306​	KY	2014​	17500​
1343307​	VA	2014​	395000​
1343310​	WV	2014​	995000​
1343311​	FL	2014​	395000​
1343312​	TX	2014​	175000​
1343320​	NY	2014​	1250000​
1343324​	CA	2014​	97500​
1343332​	FL	2014​	125000​
1343336​	FL	2014​	125000​
1343337​	TN	2014​	625000​
1343349​	FL	2014​	495000​
1343351​	PA	2014​	145000​
1343354​	FL	2014​	495000​

My output would ideally look like this for each state:

State:	KY
	Most Frequent	Total Payment	Frequency
	1​	995,000	22​
	2​	250,000	19​
	3​	1,995,000	16​
	4​	300,000	13​
	5​	700,000	10​
	6​	900,000	8​
	7​	50,000	7​
	8​	36,000	5​
	9​	750,000	3​
	10​	655,000	2​

Happy to answer any questions, thanks in advance!

 

[smit3446]

FYI found the solution:

Sub FindTop10CommonValuesByState()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("2018-2023") ' Change Sheet1 to your sheet name
    
    Dim stateRange As Range
    Set stateRange = ws.Range("B1:B" & ws.Cells(ws.Rows.count, "B").End(xlUp).Row)
    
    Dim stateDict As Object
    Set stateDict = CreateObject("Scripting.Dictionary")
    
    Dim cell As Range
    ' Get unique states
    For Each cell In stateRange
        If Not IsEmpty(cell.value) And Not stateDict.exists(cell.value) Then
            stateDict.Add cell.value, cell.value
        End If
    Next cell
    
    Dim state As Variant
    Dim outputRow As Long
    outputRow = 1
    
    ' Loop through each state
    For Each state In stateDict.Keys
        Dim dataDict As Object
        Set dataDict = CreateObject("Scripting.Dictionary")
        
        ' Loop through the data and count occurrences for the current state
        For Each cell In stateRange
            If cell.value = state Then
                Dim value As Variant
                value = ws.Cells(cell.Row, "D").value
                If Not IsEmpty(value) Then
                    If dataDict.exists(value) Then
                        dataDict(value) = dataDict(value) + 1
                    Else
                        dataDict.Add value, 1
                    End If
                End If
            End If
        Next cell
        
        ' Sort values by count
        Dim i As Integer
        Dim j As Integer
        Dim tempValue As Variant
        Dim tempCount As Variant
        
        Dim arrValues As Variant
        Dim arrCounts As Variant
        arrValues = dataDict.Keys
        arrCounts = dataDict.Items
        
        ' Bubble sort
        For i = LBound(arrCounts) To UBound(arrCounts) - 1
            For j = i + 1 To UBound(arrCounts)
                If arrCounts(i) < arrCounts(j) Then
                    tempCount = arrCounts(i)
                    arrCounts(i) = arrCounts(j)
                    arrCounts(j) = tempCount
                    
                    tempValue = arrValues(i)
                    arrValues(i) = arrValues(j)
                    arrValues(j) = tempValue
                End If
            Next j
        Next i
        
        ' Output the top 10 common values and their counts for the current state
        ws.Cells(outputRow, "E").value = "State"
        ws.Cells(outputRow, "F").value = state
        ws.Cells(outputRow, "G").value = "Value"
        ws.Cells(outputRow, "H").value = "Count"
        
        outputRow = outputRow + 1
        
        For i = 0 To Application.WorksheetFunction.Min(UBound(arrValues), 9)
            ws.Cells(outputRow, "E").value = state
            ws.Cells(outputRow, "G").value = arrValues(i)
            ws.Cells(outputRow, "H").value = arrCounts(i)
            outputRow = outputRow + 1
        Next i
        
        outputRow = outputRow + 1 ' Add an empty row between different states
    Next state
    
    MsgBox "Top 10 most common values for each state have been found and listed in columns E to H.", vbInformation
End Sub