Sort by most efficient combination

[pwillia]

Hi all,

Not sure if this is best done via excel solver, formula, or VBA, but I have the below problem:

A cell setting a maximum size, set in this example to '25'.

A set of numbers, which cannot be split, only combined, to fit into groups equaling 25, e.g.:

Size:

10

11

15

14

7

17

<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>
</tbody>

In this case I'd like the numbers to be sorted into groups where they fit into 25 as best as possible, the desired set would be below:

Size

10

15

11

14

7

17

<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>
</tbody>

The top two rows = 25, as do rows 3 and 4, finally rows 5 and 6 equal 24. It is important that the numbers do not go over 25, but can be below, as long as they're the most efficient combination to do so.

If I have a list of say 100 numbers, the objective is to minimise the amount of times I have to divide them by 25, to have as few denominators as possible.

I am really unsure how to approach this one, any help would be greatly appreciated, thank you!!

 

[MickG]

Does your list have duplicates ???

 

[pwillia]

Yes it could have duplicates, so I guess this complicates things as it will need to take into account those equal values already used. Are you thinking of using VBA for this?

Thank you!

 

[MickG]

Try this code in your datasheet, where the list of number are in column "A" starting "A1".
Results in column "C".

To Save and Run Code:-
Copy code from Thread
In Your Data sheet , Click "Alt+F11",:- Vb Window appears.
From the VBWindow toolbar, Click "Insert" ,"Module":- New VBwindow appears .
Paste Code into this window.
Close Vbwindow.

On sheet Click "Developer tab", Click "Macro". Macro dialog box appears.
Select Macro "Combs" from List.
On the right of Dialog box Click "Run"
The Sheet should now be updated.
Regrds Mick

Option Explicit
[COLOR="Navy"]Dim[/COLOR] Ray() [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Sub[/COLOR] Combs()
[COLOR="Navy"]Dim[/COLOR] rRng [COLOR="Navy"]As[/COLOR] Range, p, Dn [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] vElements, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant
Set rRng = Range("A1", Range("A1").End(xlDown)) '[COLOR="Green"][B] The set of numbers[/B][/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] rRng
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, 1
    [COLOR="Navy"]Else[/COLOR]
        Dic(Dn.Value) = Dic(Dn.Value) + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
p = 2
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Call CombinationsNP(vElements, CInt(p), vresult, lRow, 1, 1)
Call Num25(Ray, Dic)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
 
[COLOR="Navy"]Sub[/COLOR] CombinationsNP(vElements [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] iElement [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] iIndex [COLOR="Navy"]As[/COLOR] Integer)
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
 
[COLOR="Navy"]For[/COLOR] i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    [COLOR="Navy"]If[/COLOR] iIndex = p [COLOR="Navy"]Then[/COLOR]
        lRow = lRow + 1
        ReDim Preserve Ray(1 To 3, 1 To lRow)
        Ray(1, lRow) = vresult(1)
        Ray(2, lRow) = vresult(2)
        Ray(3, lRow) = Application.Sum(vresult)
    [COLOR="Navy"]Else[/COLOR]
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] Num25(R [COLOR="Navy"]As[/COLOR] Variant, D [COLOR="Navy"]As[/COLOR] Object)
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRay() [COLOR="Navy"]As[/COLOR] Variant

[COLOR="Navy"]For[/COLOR] num = 25 To 1 [COLOR="Navy"]Step[/COLOR] -1
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(R, 2)
        [COLOR="Navy"]If[/COLOR] D.exists(R(1, n)) And D.exists(R(2, n)) And R(3, n) = num [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] R(1, n) = R(2, n) And D(R(2, n)) = 1 [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] For
            ReDim Preserve nRay(c)
            nRay(c) = R(1, n)
            c = c + 1
            ReDim Preserve nRay(c)
            nRay(c) = R(2, n)
            c = c + 1
        
            [COLOR="Navy"]If[/COLOR] D(R(1, n)) > 1 [COLOR="Navy"]Then[/COLOR]
                D(R(1, n)) = D(R(1, n)) - 1
            [COLOR="Navy"]Else[/COLOR]
                D.Remove R(1, n)
            [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] D(R(2, n)) > 1 [COLOR="Navy"]Then[/COLOR]
                D(R(2, n)) = D(R(2, n)) - 1
            [COLOR="Navy"]Else[/COLOR]
                D.Remove R(2, n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] num
Range("C1").Resize(c).Value = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[pwillia]

Hi Mick,

Wow! This looks like a nice chunk of VBA! I'll have to run through it and understand what's going on. I have been away so have not been able to check, but thank you very much for your time on this, it's greatly appreciated and i'll be sure to learn a lot from it!

Kind regards,

Pete

 

[MickG]

You're welcome