VBA How to find a Specific Number based on Variable then Priority

Question

I am trying to build a excel vba code that looks at data from three columns, takes the lowest 6 values of each variable (which there are four of) and also takes the adjacent column and pastes it in another sheet.

This is the input:

This is what I would like the output to be:
!

This is what the output actually is:
Actual Output

I stole a lot of this code from another post I saw, but it seems to be acting very randomly. I'm still not quite sure what the code is even doing, which is what makes it hard for me.

Any advice will help tremendously.

UPDATE: Using Ibo's fix on my sample data, it worked perfectly, however on my actual data it errored out. The reason I am doing this through a macro instead of manually is because it is a part of a much larger macro that is getting pieced together to predict production consumption of various raw materials and what needs to get staged.

Here's what happened:

Actual Input Data

Error 1004 Message and highlighted code

Output after failure

It looks like it got close, but didn't finish with the actual sort.

Sub TopPriorityPerPod()

    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rngData As Range
    Dim rngFound As Range
    Dim rngUnqGroups As Range
    Dim GroupCell As Range
    Dim lCalc As XlCalculation
    Dim aResults() As Variant
    Dim aOriginal As Variant
    Dim lNumTopEntries As Long
    Dim i As Long, j As Long, k As Long

    'Change to grab the top X number of entries per category'
    lNumTopEntries = 6

    Set wsData = ActiveWorkbook.Sheets("copy")    'This is where your data is'
    Set wsDest = ActiveWorkbook.Sheets("Sheet6")    'This is where you want to output it'

    Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
    aOriginal = rngData.Value   'Store original values so you can set them back later'

    'Turn off calculation, events, and screenupdating'
    'This allows code to run faster and prevents "screen flickering"'
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
    'On Error GoTo CleanExit

    With rngData
        '.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
        .Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
    End With

    With rngData.Resize(, 1).Offset(, 1)
        .AdvancedFilter xlFilterInPlace, , , True
        Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        .Parent.ShowAllData 'Remove the filter

        ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
        i = 0

        For Each GroupCell In rngUnqGroups
            Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
            k = 0
            If Not rngFound Is Nothing Then
                For j = i + 1 To i + lNumTopEntries
                    If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
                        k = k + 1
                        aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
                        aResults(j, 2) = rngFound.Offset(j - i - 1).Value
                        aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
                        aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
                    End If
                Next j
                i = i + k
            End If
        Next GroupCell
    End With

    'Output results'
    wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults

    CleanExit:
    'Turn calculation, events, and screenupdating back on'
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
        'There was an error, show the error'
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    'Put data back the way it was
    rngData.Value = aOriginal

End Sub

Answer 1

So I've put something together for you that should get you most of the way there.

You'll need to do a few things to get this working for your file (learning opportunity!):

(1) Adjust the ranges as relevant to your file (2) Print the output to the worksheet. As of right now the output is being printed to the immediate debug window.

What this code will do is sort out each letters values into a collection named after the letters.

From there we convert the collection to an array. We then utilize the "Small" worksheet function on the arrays, and loop through the 6 lowest values.

Happy to help with any further questions you may have!

Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).

    Dim result  As Variant
    Dim cnt     As Long

    ReDim result(myCol.Count - 1)
    For cnt = 0 To myCol.Count - 1
        result(cnt) = myCol(cnt + 1)
    Next cnt
    CollectionToArray = result

End Function

Sub ArraySort()

Dim Cell As Range

Dim KeyMultiple As String

Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection


Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")

Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")


Counter = 0
For i = 1 To 22
        If Cells(i, 1).Value = "A" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
        ElseIf Cells(i, 1).Value = "B" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
        ElseIf Cells(i, 1).Value = "C" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
        ElseIf Cells(i, 1).Value = "D" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
        End If
Next i

For i = 1 To 6
    Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
    Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
    Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
    Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i



Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection

End Sub

Answer 2

You can have different approaches. In this method I copy the data to another sheet called Result, then insert a table, sort the columns and then collect the range where the rows are more than 6 and then delete the whole rows at once, it will be really fast:

Sub Main()
    Dim i As Long
    Dim rng As Range
    Dim tbl As ListObject
    Dim WS As Worksheet
    Dim WS2 As Worksheet

    Set WS = Worksheets("Sheet1") 'this is where you have the data
    Set WS2 = Worksheets.Add
    WS2.Name = "Result"

    WS.Range("A1").CurrentRegion.Copy
    WS2.Paste

    'sort priority column first
    WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
    Set tbl = WS2.ListObjects("Table1")

    tbl.Sort.SortFields.Add _
        Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With tbl.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'sort station column
    tbl.Sort.SortFields.Clear
    tbl.Sort.SortFields.Add _
        Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With tbl.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'remove any row exceeding 6th occurrence
    Dim cnt As Integer


    For i = 1 To tbl.ListRows.Count - 1
        If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
            cnt = cnt + 1
            If cnt >= 6 Then
                If rng Is Nothing Then
                    Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
                Else
                    Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
                End If
            End If
        Else
            cnt = 0 'reset the counter
        End If
    Next i

    'remove rows
    If Not rng Is Nothing Then
        tbl.Unlist
        rng.EntireRow.Delete
    End If

End Sub

Answer 3

here's a solution exploiting Array, Dictionary and SortedList object, that shuold be quite fast:

Option Explicit

Sub main()

    Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy")    'This is where your data is'
    Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6")    'This is where you want to output

    Dim stations As Variant, station As Variant
    Dim iStation As Long
    Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values

    With wsData
        stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
        For iStation = 1 To UBound(stations, 1)
            stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
        Next
    End With


    Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
    Dim iPriority As Long, nPriorities As Long
    For Each station In stationsList.Keys ' loop through unique stations
        prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list

        With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
            For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
                priority = Split(priorityAndOrder, "|")(0) ' get current priority
                order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
                .Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
            Next

            nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
            ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
            For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
                results(iPriority + 1, 1) = station
                results(iPriority + 1, 2) = .GetKey(iPriority)
                results(iPriority + 1, 3) = .GetValueList()(iPriority)
            Next
        End With
        wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
    Next
End Sub