AW: Rucksackproblem?
26.10.2010 12:29:44
bst
Auch Hallo,
Auch mal ein Versuch. Benötigt für die hier M.E. 21 über 15 = 54264 Möglichkeiten knapp über einer Sekunde.
Bevor Du das mit 300 Mitarbeitern machst solltest Du mal 300 über 15 ausrechnen, das sind denn rund 7,7E+24 Möglichkeiten und die Berechnung dazu (wenn ich mich nicht verrechnet habe) würde 'geschätzte' 4,5E+12 Jahre dauern ;-)
cu, Bernd
--
Option Explicit
Const N As Integer = 21
Const K As Integer = 15
Dim lngCount As Long ' wird eigentlich nicht benötigt ...
Sub main()
Dim arData As Variant
Dim ar(1 To N) As Byte
Dim i As Integer
Dim dblSum As Double, dblMax As Double
Dim strResult As String
Dim t As Single
t = Timer
lngCount = 0
arData = Range("A2:D2").Resize(N)
For i = 1 To UBound(arData)
Select Case Left(arData(i, 4), 1)
Case "C": arData(i, 4) = 0
Case "P": arData(i, 4) = 1
Case "J": arData(i, 4) = 2
Case Else: MsgBox "No." & i, vbCritical, "PANIC": Exit Sub
End Select
Next
For i = N - K + 1 To N
ar(i) = 1
Next
'Debug.Print myJoin(ar)
Do
If CheckConditions(arData, ar) Then
dblSum = CalcSum(arData, ar)
If dblSum > dblMax Then
dblMax = dblSum
strResult = myJoin(ar)
End If
End If
Loop While CanShift(ar)
For i = 1 To Len(strResult)
Cells(i + 1, 5).Value = Mid(strResult, i, 1)
Next
MsgBox Format(Timer - t, "##.00 Sekunden"), , lngCount & " Berechnungen"
End Sub
Private Function CheckConditions(arData As Variant, ar() As Byte) As Boolean
Dim Count(0 To 2) As Integer
Dim dblSum As Double
Dim i As Integer
For i = 1 To UBound(ar)
If ar(i) = 1 Then
dblSum = dblSum + arData(i, 2)
Count(arData(i, 4)) = Count(arData(i, 4)) + 1
End If
Next
CheckConditions = (Count(0) = 5 And Count(1) = 5 And Count(2) = 5 And dblSum <= 950000)
End Function
Private Function CalcSum(arData As Variant, ar() As Byte) As Double
Dim i As Integer
For i = 1 To UBound(ar)
If ar(i) = 1 Then CalcSum = CalcSum + arData(i, 3)
Next
End Function
Private Function CanShift(ar() As Byte)
Dim i As Integer, j As Integer, m As Integer
lngCount = lngCount + 1
i = 1
While ar(i) = 1
i = i + 1
Wend
j = i + 1
While ar(j) = 0
j = j + 1
If j > UBound(ar) Then Exit Function
Wend
ar(j - 1) = 1
ar(j) = 0
CanShift = True
If i > 1 And i < j Then
For m = 1 To i - 1
If ar(j - 1 - m) = 0 Then
ar(j - 1 - m) = 1
ar(m) = 0
End If
Next
End If
'Debug.Print myJoin(ar)
End Function
Private Function myJoin(ar() As Byte) As String
Dim i As Integer
For i = 1 To UBound(ar)
myJoin = myJoin & IIf(ar(i) = 0, "0", "1")
Next
End Function
