Assign Parties to Groups with Maximum Size

[Barklie]

Greetings,

I have been attempting unsuccessfully for a method to assign parties of random sizes into groups of a maximum size with the goal of minimizing the total number of groups. I am open to using formulas or VBA for solving this problem.

Data Example.xlsx
	A	B	C	D	E	F	G	H	I
1	Party ID	Size					Group ID	Size	Parties
2	A	1		Max Group Size	13		Group A	13	A, H
3	B	10		Min Group #	8		Group B	13	B, L
4	C	4					Group C	12	C, J
5	D	4					Group D	12	D, I
6	E	13					Group E	13	E
7	F	11					Group F	11	F
8	G	10					Group G	10	G
9	H	12					Group H	10	K
10	I	4
11	J	8
12	K	10
13	L	3
Sheet1

Truthfully, I have yet to think of a fail-proof way to this conceptually. Thanks for any help!

Regards,
Barklie Estes

 

[Jeffrey Mahoney]

Please try this:

It assumes the group list with party size begins at cell A2. Output to G2. Sorting the list maximizes the chances of getting group sizes near the max

Sub GroupByMax()
  Dim Cel As Range
  Dim Rng As Range
  Dim OutRng As Range         'Top left cell of new list
  Dim vAry As Variant
  Dim X As Long
  Dim Grp As String
  Dim PrtySize As Long        'Current Party size
  Dim Acct() As Boolean       'Array to set individual status of groups
  Dim GrpCnt As Long
  Dim MaxGrpSize As Long
  Dim OutCnt As Long
  Dim Grps As String          'Many groups
  Dim GrpSize As Long         'Current Group party size
  Dim Y As Long
  Dim AcctCnt As Long         'Store count of group status
  Dim Sht As Worksheet
  Dim Key As Range
  
  MaxGrpSize = 13             'Add your code to get the value from the worksheet
  
  Set Sht = ActiveSheet
  
  Set Rng = Range("A2:B27")               'Full set of groups and party size
  Set Key = Range("B2:B27")               'Party Size column
  
  Sht.Sort.SortFields.Clear               'Sort by party size largest on top
  Sht.Sort.SortFields.Add2 Key:=Key, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  With Sht.Sort
    .SetRange Rng
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  
  
  Set OutRng = Range("G1")                                '<--- Change this
  
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  vAry = Application.Transpose(Application.Transpose(Rng))
  GrpCnt = UBound(vAry)
  ReDim Acct(1 To GrpCnt)
  For X = 1 To GrpCnt                                       'Go through each Group
    Grp = vAry(X, 1)
    PrtySize = vAry(X, 2)
    Grps = Grp
    GrpSize = PrtySize
    
    If Acct(X) = False Then
      
      If PrtySize >= MaxGrpSize Then                      'Already max party size
        OutCnt = OutCnt + 1
        OutRng.Offset(OutCnt, 0).Value = Grps             'Add to new list
        OutRng.Offset(OutCnt, 1).Value = PrtySize
        Acct(X) = True
        AcctCnt = AcctCnt + 1
      ElseIf PrtySize < MaxGrpSize Then                    'Go get more groups to get add
        For Y = X + 1 To GrpCnt
          If Acct(Y) = False And vAry(Y, 2) <= (MaxGrpSize - GrpSize) Then    'Will it fit?
            Grps = Grps & ", " & vAry(Y, 1)
            GrpSize = GrpSize + vAry(Y, 2)
            Acct(Y) = True
            AcctCnt = AcctCnt + 1
            If GrpSize = MaxGrpSize Then Exit For       'Maxed out
          End If
        Next Y
        OutCnt = OutCnt + 1                             'add to new list
        OutRng.Offset(OutCnt, 0).Value = Grps
        OutRng.Offset(OutCnt, 1).Value = GrpSize
      End If
    End If
    
    If AcctCnt = GrpCnt Then Exit For
    
    
  Next X
  
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  
End Sub

 

[Barklie]

Jeffrey,

That's very clever. If I understand correctly, you sort largest to smallest, try to add the largest, non-max group to the second largest, and move down from there. There are probably some weird instances where this wouldn't optimize (like parties of 7,5,4,4,3,3), but this is more than sufficient for my application where I will be using it to parallel electrical circuits into groups 20amps or under.

Thank you greatly.

Regards,
Barklie Estes