|
Allerdings, sind da ein paar Fehler drinnen. Hier nochmal eine funktionierende Version:
Kurzform ohne Optimierung:
'***************************
'*In Reihenfolger verteilen*
'***************************
Function AllocateSimple(Arr(), ByVal Items, Cap#) As Double
Dim a&, I&, J&, S&, E&, Spot#()
Dim Sum#, V#, nV#
'set
S = LBound(Items)
E = UBound(Items)
'allocate items
For a = S To E
If Items(a) > 0 Then
If a < E Then nV = CDbl(Items(a + 1))
V = CDbl(Items(a))
ReDim Preserve Spot(I)
Spot(I) = a
I = I + 1
Sum = Sum + V
If Sum + nV > Cap Or a = E Then
ReDim Preserve Arr(J)
Arr(J) = Spot
J = J + 1
Sum = 0
I = 0
End If
End If
Next
End Function
Optimierte Verteilung:
'***********************
'*Verteilung optimieren*
'***********************
Function Allocate(Arr(), ByVal Items, Cap#) As Double
Dim a&, b&, c&, I&, J&, S&, E&, E2&, Found&
Dim Spot#(), Ind&()
Dim Sum#, V#
Dim setA As Boolean
Dim Max#, MaxInd&
'set
S = LBound(Items)
E = UBound(Items)
E2 = E
QSStart Items, Ind, E, xlDescending
'allocate items
For a = S To E
For b = a To E2
V = Items(b)
If Sum + V <= Cap Then
ReDim Preserve Spot(I)
Spot(I) = Ind(b)
I = I + 1
Sum = Sum + V
For c = b To a + 1 Step -1
Items(c) = Items(c - 1)
Ind(c) = Ind(c - 1)
setA = True
Next
If setA Then
setA = False
a = a + 1
End If
End If
Next
ReDim Preserve Arr(J)
Arr(J) = Spot
J = J + 1
Found = Found + I
If Found >= E2 Then Exit For
I = 0
Sum = 0
Next
End Function
Private Function QSStart(ByRef Arr, ByRef Ind&(), dE&, Optional Order As XlSortOrder = xlAscending)
Dim S&, I&
S = LBound(Arr)
ReDim Ind(S To dE)
For I = S To dE
Ind(I) = I
Next
QSArray Arr, Ind, S, dE, IIf(Order = xlAscending, 1, 0)
End Function
Private Function QSArray(ByRef Arr, ByRef Ind&(), a&, E&, Optional ByVal Asc As Boolean = True)
Dim varTemp
Dim varPivot
Dim x&, y&
'set
x = a
y = E
varPivot = Arr((a + E) \ 2)
'loop
Do While x <= y
If Asc Then
Do While Arr(x) < varPivot
x = x + 1
Loop
Do While Arr(y) > varPivot
y = y - 1
Loop
Else
Do While Arr(x) > varPivot
x = x + 1
Loop
Do While Arr(y) < varPivot
y = y - 1
Loop
End If
If x <= y Then
varTemp = Ind(x)
Ind(x) = Ind(y)
Ind(y) = varTemp
varTemp = Arr(x)
Arr(x) = Arr(y)
Arr(y) = varTemp
x = x + 1
y = y - 1
End If
Loop
If a < y Then Call QSArray(Arr, Ind, a, y, Asc)
If x < E Then Call QSArray(Arr, Ind, x, E, Asc)
End Function
Bei der optimierten Version werden immer erst die größten möglichen Elemente "verbraucht". Ich weiß nicht, ob es eine Regel oder ein Verfahren gibt was besser funktioniert, aber damit spaart man bei einer größeren Anzahl schonmal locker 10% der Elemente (Strings oder was auch immer).
|