Function TestSubset(NumberOfElements As Long, NumberOfValues As Long, MinimumElements As Long, MaximumElements As Long, RemainingGroups As Long) As Boolean
TestSubset = ((NumberOfValues - NumberOfElements) >= (RemainingGroups * MinimumElements)) And ((NumberOfValues - NumberOfElements) <= (RemainingGroups * MaximumElements))
End Function
Function GenSubsets(Subsets As Collection, Element As Variant, GroupSum As Double) As Collection
' Function to generate new subsets after adding the element
Dim NewSubset As Collection
Dim Subset As Variant
Set GenSubsets = New Collection
For Each Subset In Subsets
' Return the subset
GenSubsets.Add Subset
' Create the new subset with the new element added
Set NewSubset = New Collection
Dim Item As Variant
For Each Item In Subset
NewSubset.Add Item
Next Item
NewSubset.Add Element
If SumCollection(NewSubset) <= GroupSum Then
GenSubsets.Add NewSubset
End If
Next Subset
End Function
Function GenerateSubsets(Elements As Collection, GroupSum As Double) As Collection
Dim Subsets As Collection
Set Subsets = New Collection
Subsets.Add New Collection ' Start with an empty subset
Dim Element As Variant
For Each Element In Elements
Set Subsets = GenSubsets(Subsets, Element, GroupSum)
Next Element
' Return the generator to iterate through the obtained subsets
Set GenerateSubsets = Subsets
End Function
Sub CalculCol()
Dim ws As Worksheet, NbIters As Long, arrVal
Dim NumberOfGroups As Long, MinimumElements As Long, MaximumElements As Long
Set ws = Worksheets("Répartition")
NumberOfGroups = ws.Range("NbGroupes").Value
MinimumElements = ws.Range("MinElem").Value
MaximumElements = ws.Range("MaxElem").Value
NbIters = ws.Range("NbIters").Value
arrVal = WorksheetFunction.Transpose(ws.Range("Valeurs"))
ws.Range("NumEssai").Value = 0
Dim Values As Collection
Set Values = New Collection
Dim OriginalValues As Object
Set OriginalValues = CreateObject("System.Collections.ArrayList")
Dim Value As Variant
'For Each Value In Array(56.94624, 39.104, 27.98432, 26.9568, 60.54048, 48.8072, 49.55808, 31.85, 50.752, 55.3696, _
' 46.78128, 34.80048, 38.75508, 55.13664, 39.3354, 37.37448, 80.3374, 19.24208, 12.3786)
For Each Value In arrVal
Values.Add CDbl(Value)
OriginalValues.Add CDbl(Value)
Next Value
Set Values = ShuffleCollection(Values)
'NumberOfGroups = 7
Dim Deviation As Double
Deviation = 0
Dim GroupSum As Double
GroupSum = SumCollection(Values) / NumberOfGroups
Debug.Print GroupSum
'MinimumElements = 2
'MaximumElements = 3
Randomize
Dim MaximumDeviation As Double
MaximumDeviation = 9999
Dim n As Long, i As Long, cpti As Long
Dim Numbers As Collection, GroupList As Collection
Dim Subset As Variant, ValueInSubset As Variant
For n = 0 To NbIters
Deviation = 0
ws.Range("NumEssai").Value = n
Do While Deviation <= 10
Set Numbers = CloneCollection(Values)
Set GroupList = New Collection
For i = 0 To NumberOfGroups - 2
cpti = i
For Each Subset In GenerateSubsets(Numbers, GroupSum + Deviation)
' If the sum of the integers in the subset is equal to GroupSum plus or minus the deviation
If Abs(SumCollection(Subset) - GroupSum) <= Deviation Then
If (Subset.count >= MinimumElements) And (Subset.count <= MaximumElements) And TestSubset(Subset.count, Numbers.count, MinimumElements, MaximumElements, (NumberOfGroups - i - 1)) Then
' Add the subset of numbers
GroupList.Add Subset
For Each ValueInSubset In Subset
RemoveFromCollection Numbers, ValueInSubset
Next ValueInSubset
Exit For
End If
End If
Next Subset
If GroupList.count = i Then
Exit For ' Exit the loop
End If
Next i
If GroupList.count > cpti Then
' Debug.Print "Exit cpti"
Exit Do ' Exit the loop
End If
Deviation = Deviation + 0.1 ' Increment the deviation for a search
Loop
' Debug.Print "Fin Loop"
GroupList.Add Numbers ' Add the last group to the list
Dim SumsGroups As Collection
Set SumsGroups = New Collection
Dim LengthsGroups As Collection
Set LengthsGroups = New Collection
Dim Group As Variant
For Each Group In GroupList
SumsGroups.Add SumCollection(Group)
LengthsGroups.Add Group.count
Next Group
Dim MaxDeviation As Double
MaxDeviation = MaxCollection(SumsGroups) - MinCollection(SumsGroups)
If MaxDeviation < MaximumDeviation Then
Debug.Print "n : " & n & " -> max deviation = " & MaxDeviation
MaximumDeviation = MaxDeviation
i = 1
Dim elem As Variant, subelem As Variant
ReDim grpVal(0 To OriginalValues.count - 1) As Integer
For Each elem In GroupList
For Each subelem In elem
grpVal(OriginalValues.IndexOf(subelem, 0)) = i
Next subelem
i = i + 1
Next elem
ws.Range("Groupes").Value2 = Application.Transpose(grpVal)
End If
Set Values = ShuffleCollection(Values)
Next n
End Sub
Function SumCollection(ByVal Col As Collection) As Double
Dim Total As Double
Total = 0
Dim Item As Variant
For Each Item In Col
Total = Total + Item
Next Item
SumCollection = Total
End Function
Sub RemoveFromCollection(ByRef Col As Collection, Item As Variant)
Dim i As Long
For i = Col.count To 1 Step -1
If Col(i) = Item Then
Col.Remove i
End If
Next i
End Sub
Function ShuffleCollection(ByVal Col As Collection) As Collection
Set ShuffleCollection = New Collection
Randomize
Do While Col.count > 0
Dim randomIndex As Integer
randomIndex = Int(Rnd() * Col.count) + 1
ShuffleCollection.Add Col(randomIndex)
Col.Remove randomIndex
Loop
End Function
Function CloneCollection(ByVal Col As Collection) As Collection
Dim elem As Variant
Set CloneCollection = New Collection
For Each elem In Col
CloneCollection.Add elem
Next elem
End Function
Function MaxCollection(ByVal Col As Collection) As Double
Dim Max As Double
Max = 0
Dim Item As Variant
For Each Item In Col
If Item > Max Then Max = Item
Next Item
MaxCollection = Max
End Function
Function MinCollection(ByVal Col As Collection) As Double
Dim Min As Double
Min = 99999
Dim Item As Variant
For Each Item In Col
If Item < Min Then Min = Item
Next Item
MinCollection = Min
End Function
Sub ReinitGroupes()
Range("Groupes").Value2 = 0
Range("NumEssai").Value = 0
End Sub