Zurück zur Homepage

Zahlkombinationen bilden

In der Newsgroup tauchte die Frage auf, wie man aus einem gegebenen Zielwert und einer Liste von Zahlen diejenigen ermitteln kann, die zusammengezählt den Zielwert ergeben.

Neben einigen sehr schönen Lösungen, beispielsweise mit dem Solver, wurde auch eine Seite empfohlen, die im Jahr 2002 einen Wettbewerb gestartet hat. Dabei sollten für den Herrn Excel folgende Zahlen derart kombiniert werden, dass man als Ergebnis 4,556.92 herauskommt.

895,39
83,6
280,71
1021,70
219,10
1587,52
507,8
628,89
222,52
192,65
194,58
764,18
680,23
244,22
89,40
862,12
1842,59
329,97
444,98
630,92
440,93
324,84
978,53
144,77
230,72
456,68
126,69
2487,85
515,11
911,45
983,98
329,17
673,47
409,17
228,31
796,76
116,14
858,97
718,32
346,35
542,12
589,18
789,77
185,58
538,64
441,43
925,39
698,27
5465,45
160,62
722,73
691,83
77,74
365,43
 

Nachfolgend Code von mir, der aber nur eine einzige mögliche Lösung liefert. Ist eine soche gefunden, wird sofort abgebrochen. Man könnte den Code auch ohne Probleme so umschreiben, dass jede gefundene Lösung direkt in ein Tabellenblatt eingetragen wird, bei der großen Anzahl von Möglichkeiten ist das aber eine extrem zeitaufwendige Sache. Dadurch, dass Rekursionen eingesetzt werden, ist dieser Code aber recht kurz.

Mein Ergebnis: 4,556.92
77,74
83,6
89,4
116,14
126,69
144,77
160,62
185,58
192,65
194,58
219,1
222,52
228,31
230,72
244,22
280,71
346,35
441,43
456,68
515,11

 Beispieldatei (Ergebnissuche.zip 12 kB) 

Das Klickereignis eines Buttons im Tabellenblatt:  

Private Sub cmbBerechnen_Click()
Dim dblZielwert   As Double
Dim dblToleranz   As Double
Dim adblBeträge() As Double
Dim varResult     As Variant
Dim m             As Long
Dim n             As Long

With Me
   dblZielwert = .Range("B2")
   dblToleranz = .Range("C2")
   
ReDim adblBeträge(1 To 100)
   
For m = 2 To 101
      
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
         adblBeträge(m - 1) = .Cells(m, 1)
      
Else
         
ReDim Preserve adblBeträge(1 To m - 1)
         
Exit For
      
End If
   
Next
   
ReDim Preserve adblBeträge(1 To UBound(adblBeträge) - 1)

   varResult = Kombinationen(adblBeträge, dblZielwert, dblToleranz)
   Application.ScreenUpdating = 
False
      .Range("D3:D65536").ClearContents
      .Range(.Cells(3, 4), .Cells(
UBound(varResult) + 3, 4)) = _
         varResult
   Application.ScreenUpdating = 
True
End With
End Sub

In ein allgemeines Modul:   

Public Function Kombinationen( _
   Elemente 
As Variant, _
   Sollwert 
As Double, _
   
Optional Toleranz As Double, _
   
Optional Bisher As Variant, _
   
Optional Pos As LongAs Variant

Dim i             As Long
Dim k             As Long
Dim dblVergleich  As Double
Dim dblDummy      As Double
Dim varDummy      As Variant
Dim varResult     As Variant


If Not IsMissing(Bisher) Then

   
'Summe bisherige Elemente
   
For Each varDummy In Bisher
      dblVergleich = dblVergleich + varDummy
   
Next

Else

   
'Ausgangselemente nach Größe sortieren
   
For i = 1 To UBound(Elemente)
       
For k = i + 1 To UBound(Elemente)
           
If Elemente(k) < Elemente(i) Then
               dblDummy = Elemente(i)
               Elemente(i) = Elemente(k)
               Elemente(k) = dblDummy
           
End If
       
Next
   
Next

   
Set Bisher = New Collection

End If

If Pos = 0 Then Pos = LBound(Elemente)
For i = Pos To UBound(Elemente)

   
' Aktuellen Wert hinzufügen
   Bisher.Add Elemente(i)
   dblVergleich = dblVergleich + Elemente(i)

   
If Abs(Sollwert - dblVergleich) < (0.001 + Toleranz) Then

      
'Sollwert ist erreicht
      k = 0
      
ReDim varResult(0 To Bisher.Count - 1, 0)
      
For Each varDummy In Bisher
         varResult(k, 0) = varDummy
         k = k + 1
      
Next
      Kombinationen = varResult
      
Exit For

   
ElseIf dblVergleich < (Sollwert + 0.001 + Toleranz) Then
      
' Es ist noch Platz für einen Betrag
      
' Rekursiv aufrufen, beginnen mit nächsthöherem Wert
      varResult = Kombinationen( _
         Elemente, Sollwert, Toleranz, Bisher, i + 1)
      
If IsArray(varResult) Then
         Kombinationen = varResult
         
Exit For
      
Else
         Bisher.Remove Bisher.Count
         dblVergleich = dblVergleich - Elemente(i)
      
End If

   
Else

      
' Wert ist zu groß
      Bisher.Remove Bisher.Count
      
Exit For

   
End If

Next ' Nächsthöhere Zahl probieren

End Function