Zahlen in Gruppen gleichmäßig aufteilen

[Nemo1983]

Hallo,

folgendes Problem: Habe 200 Werte und möchte diese gerne auf 4er Gruppen aufteilen. Dabei soll die Summe jeder Gruppe ungefähr gleich sein - Wenn möglich die optimale Lösung...
Wobei jede Gruppe muss 4 Werte enthalten!
Hat jemand eine Ahnung wie ich das machen kann? (ich möchte natürlich immer die 4 Zahlen wissen, die er zusammenfügt...)

Danke,
LG Nemo

[GMG-CC]

Verlinkst du bitte deine Beiträge in unterschiedlichen Foren untereinander?
Schließlich gibt es im Nachbarforum schon eine Antwort.
Und die meisten Helfer mögen kein Crossposting ohne Querverweis.

[Nemo1983]

Hallo,

folgendes Problem: Habe 200 Werte und möchte diese gerne auf 4er Gruppen aufteilen. Dabei soll die Summe jeder Gruppe ungefähr gleich sein - Wenn möglich die optimale Lösung...
Wobei jede Gruppe muss 4 Werte enthalten!
Hat jemand eine Ahnung wie ich das machen kann? (ich möchte natürlich immer die 4 Zahlen wissen, die er zusammenfügt...)
http://www.office-fragen.de/index.php/to...975.0.html
habe auch schon in einem anderen Forum um eine Lösung ersucht, aber bis jetzt keine gefunden....

Danke,
LG Nemo

[Fennek]

Hallo,

mit der Formel von Lupo kam ich nicht zurecht.

Hier ein halb-manueller Ansatz, der vermutlich nicht das Optimum liefert, aber einige Schritte dahin.

Der Makro muss von Hand wiederholt ausgeführt werden, bis es in Spalte L keine Verbesserung mehr gibt.

Code:

Sub iStart()
With Range("A1:D50")
   .Formula = "=int(rand()*1000)"
   .Value = .Value
End With
Range("F1:F50").Formula = "=sum(RC[-5]:RC[-2])"
Range("H1") = "min"
Range("H2") = "max"
Range("I1").Formula = "=min(F1:F50)"
Range("I2").Formula = "=max(F1:F50)"
Range("J1").Formula = "=match(I1,F1:F50,0)"
Range("J2").Formula = "=match(I2,F1:F50,0)"
End Sub


Sub iFen()
Dim WSF As WorksheetFunction: Set WSF = Application.WorksheetFunction
Dim RMin As Range
Dim RMax As Range
lr = Cells(Rows.Count, "L").End(xlUp).Row + 1
Cells(lr, "L") = Cells(2, "I") - Cells(1, "I")
Mn = Range("J1")
Mx = Range("J2")
Set RMin = Range(Cells(Mn, 1), Cells(Mn, 4))
Set RMax = Range(Cells(Mx, 1), Cells(Mx, 4))
Mi = WSF.Min(RMin)
Ma = WSF.Max(RMax)
Cl = WSF.Match(Mi, RMin, 0)
Ch = WSF.Match(Ma, RMax, 0)

Cells(Mn, Cl) = Ma
Cells(Mx, Ch) = Mi

End Sub

mfg

[Nemo1983]

Hallo,

also habe das versucht und es klappt nicht wirklich - siehe Anhang...
es müsste die erste Gruppe eigentlich: 272,1,1,1 sein und dann weiter... klappt leider nicht, aber danke für den Versuch!

[snickers]

mit der Formel von Lupo kam ich nicht zurecht.

Vermutlich, weil Du die Einschränkungen nicht gelesen hast.
Mit einer Zahlenreihe 1 bis 200 klappt es punktgenau; die Summe ist immer (50 Mal) 402. Je mehr man von so einer Gleichverteilung der Zahlen wegkommt, desto dringender werden andere Lösungen.

[Nemo1983]

nur leider funktioniert es mit meinen Zahlen nicht, jemand einen Plan wie ich das mit meinen Werten umsetzen kann?

[Fennek]

Hallo,

noch ein Versuch (hoffentlich nicht zu nahe an Lupos Vorschlag)

Code:

Sub Start2()
With Range("A1:A200")
   .Formula = "=int(rand()*1000)+1"
   .Value = .Value
   .Offset(, 10).Formula = "=sum(rc[-5]:rc[-2])"
End With
End Sub

Sub iFen2()
Dim WSF As WorksheetFunction: Set WSF = Application.WorksheetFunction
Dim RMin As Range
Dim RMax As Range
Dim r As Range
Set r = Range("A1:A200")
For i = 1 To 100 Step 2
   Z = Z + 1
   Cells(Z, 6) = WSF.Large(r, i)
   Cells(Z, 7) = WSF.Large(r, i + 1)
   Cells(Z, 8) = WSF.Small(r, i)
   Cells(Z, 9) = WSF.Small(r, i + 1)
Next i
Debug.Print Mi, Mir
End Sub

mfg

[Storax]

Hier gab es mal ein ähnliches Problem.
Du müsstest den Greedy-Algorithmus quasi zweimal anwenden.

[Fennek]

Hallo,

ohne den link von Storax zu kennen:

Der Code erzeugt Paare, die sehr nahe am Sollwert sind, die Kombination zweier dieser Paare sollte der optimalen Lösung nahe kommen.

Code:

Sub Start2()
With Range("A1:A200")
   .Formula = "=int(rand()*1000)+1"
   .Value = .Value
   .Copy Cells(1, 3)
   .Offset(, 10).Formula = "=sum(rc[-5]:rc[-2])"
End With
End Sub


Sub iFen4()
Dim WSF As WorksheetFunction: Set WSF = Application.WorksheetFunction
Dim Bo As Boolean: Bo = True
Dim Ziel As Integer
Ziel = WSF.Sum(Range("C1:C200")) / 100

Do While Bo
   i = i + 1
   If Not IsEmpty(Cells(i, 3)) Then
       Top = 1000
       For j = i + 1 To 200
       If Not IsEmpty(Cells(j, 3)) Then
           If Abs(Cells(i, 3) + Cells(j, 3) - Ziel) < Top Then
               Top = Abs(Cells(i, 3) + Cells(j, 3) - Ziel)
               jj = j
           End If
       End If
       Next j
       r = r + 1
       Cells(r, 6) = Cells(i, 3)
       Cells(r, 7) = Cells(jj, 3)
       Cells(jj, 3).Clear
   End If
   If i > 100 Then Bo = False
Loop
End Sub

mfg