gleiche Verteilung von Lasten
09.07.2010 00:51:44
Lasten
Hi Christian,
exakt dein Ergebnis kommt hier raus:
| A | B | C | D |
1 | Gewichte | Korb1 | Korb2 | Korb3 |
2 | 46 | 46 | | |
3 | 23 | | 23 | |
4 | 22 | | | 22 |
5 | 17 | | 17 | |
6 | 15 | | | 15 |
7 | 14 | | | 14 |
8 | 8 | | 8 | |
9 | 6 | 6 | | |
10 | | | | |
11 | Summen: | 52 | 48 | 51 |
Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Die Prozedur dazu:
Option Explicit
Sub VerteileGleichm()
Dim w, ii As Long, strX As String, dblAbw As Double, ss As Long
Dim arrK(1 To 8) As Long, arrE(1 To 8) As Double, sumK(2) As Double
Dim dblMw As Double, dblMin As Double
w = Application.Transpose(Cells(2, 1).Resize(8)) ' Werte aus A2:A9
dblMin = 1E+308
dblMw = Application.Sum(w) / 3#
For ii = 0 To 1457
strX = Right("0000000" & Dez2ZSys(ii, 3), 8)
Erase sumK
For ss = 1 To 8
arrK(ss) = Mid(strX, ss, 1)
sumK(arrK(ss)) = sumK(arrK(ss)) + w(ss)
Next ss
' dblAbw = Abs(dblMw - sumK(0)) + _
Abs(dblMw - sumK(1)) + _
Abs(dblMw - sumK(2)) ' Abw. vom Mittelwert
dblAbw = (dblMw - sumK(0)) ^ 2 + _
(dblMw - sumK(1)) ^ 2 + _
(dblMw - sumK(2)) ^ 2 ' quadrat. Abw. vom Mittelwert
If dblMin > dblAbw Then
dblMin = dblAbw
For ss = 1 To 8
arrE(ss) = arrK(ss)
Next ss
End If
Next ii
Cells(2, 2).Resize(8, 3).ClearContents
For ss = 1 To 8
Cells(ss + 1, 1) = w(ss)
Cells(ss + 1, arrE(ss) + 2) = w(ss)
Next ss
Cells(ss + 2, 2).Resize(, 3).Formula = "=SUM(B2:B9)"
End Sub
Function Dez2ZSys(ByVal dd As Double, bas As Integer) As String
Dim ss As Double, nn As Integer
If bas = ss * bas
ss = ss * bas
Wend
While ss >= 1
nn = dd \ ss
dd = dd - nn * ss
Dez2ZSys = Dez2ZSys & Chr(nn + 48 - 7 * (nn > "9"))
ss = ss / bas
Wend
End Function
Bei der Berechnung der Abweichung dblAbw habe ich die erste Version (Abw. vom Mittelwert)
als Kommentar stehen gelassen. Bessere Ergebnisse liefert die quadratische Abweichung.
Und hier noch eine Bei-Spiel-Mappe: https://www.herber.de/bbs/user/70504.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort