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 Long) As 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