Rearrange a list based on criteria

[John Luther]

Hi All,

Suppose I have an array such as this one, with a schedule of fruits and quantities:

A Orange 3
B Banana 1
C Banana 1
D Orange 1
E Banana 1
F Orange 1
G Banana 3
H Banana 3
I Orange 2


But I'd like to "sort" it this way, so that I keep the sort order until a fruit reaches a qty of 3, and then no more of that fruit is included until the other fruit has reached a qty of 3.

A Orange 3
B Banana 1
C Banana 1
E Banana 1
D Orange 1
F Orange 1
G Banana 3
I Orange 2
H Banana 3

Sorry for the convoluted example. I hope it gets the point across. What I've tried so far and what I would like to do is pull the list into a 2d array and loop through the list populating another array. None of my attempts have been successful enough to describe.

Anyone have any suggestions?

Thanks

 

[Eric W]

Definitely an odd question. How many different fruits are you looking at? Do you want a formula or VBA? Which version of Excel do you have? (It would be helpful if you could update your user profile with that information.) On your row I, the "current" sum of Orange is 4. At the next break point, do you only want to look for 2 more oranges, or will the count reset on row I?

 

[John Luther]

I definitely need a vba solution. I'm on excel 2019. I'm hoping to do something looping through an array.

It will always be two fruits. I'm trying to redistribute the fruits, keeping as much as possible to the order of the list, but promoting some until a minimum tally has been met for each fruit and then resetting.

On row I, the "current" sum of Orange would be 4 - satisfying the tally. So it would reset. I don't care about exceeding the tally on any particular line, but it should reset after doing so. If that makes sense.

 

[Eric W]

I'm sure this can be improved a lot, but it works on your sample data.

Open a copy of your workbook. Press Alt-F11 to open the VBA editor. Press Alt-IM to Insert a Module. Paste the follow code in the window that opens:

Sub Sort3()
Dim tl As Range, out As Range
Dim md As Variant, mo() As Variant, sdtot As Object, sdctr As Object
Dim r As Long, r2 As Long, wk As Variant
    
    Set tl = Range("A2")
    Set out = Range("E2")
    
    md = Range(tl, tl.End(xlDown).Offset(, 2)).Value
    Set sdtot = CreateObject("Scripting.Dictionary")
    Set sdctr = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(md)
        sdtot(md(r, 2)) = sdtot(md(r, 2)) + 1
    Next r
    wk = sdtot.keys
    sdctr(wk(0)) = 0
    sdctr(wk(1)) = 0
    ReDim mo(1 To UBound(md), 1 To 3)
    r2 = 0
    
    While r2 < UBound(md)
        For r = 1 To UBound(md)
            If md(r, 2) <> "" Then
                If (sdtot(wk(0)) = 0 Or sdtot(wk(1)) = 0) Or _
                   sdctr(md(r, 2)) < 3 Then
                    r2 = r2 + 1
                    mo(r2, 1) = md(r, 1)
                    mo(r2, 2) = md(r, 2)
                    mo(r2, 3) = md(r, 3)
                    sdtot(md(r, 2)) = sdtot(md(r, 2)) - 1
                    sdctr(md(r, 2)) = sdctr(md(r, 2)) + md(r, 3)
                    md(r, 2) = ""
                    Exit For
                End If
            End If
        Next r
    
        If sdctr(wk(0)) >= 3 And sdctr(wk(1)) >= 3 Then
            sdctr(wk(0)) = 0
            sdctr(wk(1)) = 0
        End If
    Wend
            
    out.Resize(UBound(md), 3).Value = mo
End Sub

Change the top 2 lines (both say Set ...) to the top left cell of your data, and the next one to the top left cell where you want the results. It can be the same cell if you want. Press Alt-Q to close the editor. While on the sheet with your data, press Alt-F8 to open the macro selector. Select Sort3 and click run.

Let me know how it works for you.