'Create groups of 24 using Solver
I have a list of 60 schools in range A2:A61.
In Column B, I have a # of Students for each of the schools in A.
I want classes of 24, not splitting up students from the same school.
I'm trying to create groups of 24 using Solver.
In Column C, I have a column of 0s
In Column D, I have the product of Column B * Column C
In D62, I have the total of D2:D61.
I use Solver to try to make D62 = 24 while changing the 0s in Column C, with the constraint that the values of Column C must be binary.
Sub Grouping()
Dim setCellRange As Range, valueofRange As Range, byChangeRange As Range
Set setCellRange = ActiveSheet.Range("D62")
Set valueofRange = ActiveSheet.Range("B63")
Set byChangeRange = ActiveSheet.Range("C2:C61")
Dim i As Long
For i = 1 To 3
Application.Calculation = xlAutomatic
SolverReset
SolverOk SetCell:=setCellRange.Address, MaxMinVal:=3, ValueOf:=valueofRange.Address, ByChange:=byChangeRange.Address, _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverAdd CellRef:=byChangeRange.Address, Relation:=5, FormulaText:="binary"
SolverOk SetCell:=setCellRange.Address, MaxMinVal:=3, ValueOf:=valueofRange.Address, ByChange:=byChangeRange.Address, _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverOk SetCell:=setCellRange.Address, MaxMinVal:=3, ValueOf:=valueofRange.Address, ByChange:=byChangeRange.Address, _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverSolve
Set setCellRange = setCellRange.Cells(1, 4)
Set valueofRange = valueofRange.Cells(1, 1)
Set byChangeRange = byChangeRange.Cells(1, 4)
Cells(1, i * 3 + 2).Value = "# of Students"
Cells(2, i * 3 + 2).Value = "=RC[-3]-RC[-1]"
Cells(2, i * 3 + 2).Select
Selection.AutoFill Destination:=Range(Cells(2, i * 3 + 2), Cells(61, i * 3 + 2))
Range(Cells(2, i * 3 + 2), Cells(61, i * 3 + 2)).Select
Cells(1, i * 3 + 3).Value = "Binary"
Cells(2, i * 3 + 3).Value = "0"
Cells(2, i * 3 + 3).Select
Selection.AutoFill Destination:=Range(Cells(2, i * 3 + 3), Cells(61, i * 3 + 3))
Range(Cells(2, i * 3 + 3), Cells(61, i * 3 + 3)).Select
Cells(1, i * 3 + 4).Value = "Product"
Cells(2, i * 3 + 4).Value = "=RC[-2]*RC[-1]"
Cells(2, i * 3 + 4).Select
Selection.AutoFill Destination:=Range(Cells(2, i * 3 + 4), Cells(61, i * 3 + 4))
Range(Cells(2, i * 3 + 4), Cells(61, i * 3 + 4)).Select
Cells(62, i * 3 + 4).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-60]C:R[-1]C)"
Next i
End Sub
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|
