Kombinieren von Einzelwerten wie Briefmarken oder Münzen zu einem Sollwert!

Man hat ein paar Briefmarken und muss ein Päckchen frankieren. Aber welche Markenkombinationen ergeben den gewünschten Wert?
Gar nicht so einfach. Denn je mehr und je kleinere Einzelwerte zur Verfügung stehen, desto mehr Kombinationen ergeben den Zielwert. Das ist aber genau die richtige Aufgabe für einen Rechenknecht, der pro Sekunde viele tausend Kombinationen durchprobieren kann.
Mittels dem vorliegenden Code werden alle Kombinationen bis zu einer festzulegenden Anzahl von Einzelwerten durchprobiert. Die Ergebnisse werden nachher in ein Tabellenblatt eingetragen.
Selbstverständlich kann ich nicht garantieren, dass der Code fehlerfrei ist und auch nicht, ob tatsächlich alle Kombinationen durchprobiert werden. Gerade bei rekursiven Aufrufen von Funktionen können kleine Fehler fatale Folgen haben. Auch sollte man nicht zu viele (kleine) Einzelwerte benutzen und auch nicht die Anzahl der maximal zu verwendenden Werte zu hoch setzen, da die Rechenzeit extrem ansteigen kann.

Beispieldatei Kombinationen.zip 20 KB) 

'Auf ein Tabellenblatt ein Button (aus der Steuerelement-Toolbox) mit dem Namen cmbBerechnen
'In die Zelle B2 den Sollwert
'In die Zelle C2 die Toleranzgrenze
'In die Zelle D2 die maximale Anzahl der Einzelwerte
'In den Bereich A2:A20 die zu benutzenden Einzelwerte. Es werden die Werte ab A2
'bis zur ersten leeren Zelle verwendet.
'In das Klassenmodul des Tabellenblatts folgende Ereignisprozedur 

Option Explicit

Private Sub cmbBerechnen_Click()
Dim Zielwert As Double, Toleranz As Double, MaxAnzahl As Long
Dim m As Long, n As Long, a() As Double, c
On Error Resume Next
With Me
    Zielwert = .Range("B2") 'Sollwert
    Toleranz = .Range("C2") 'Toleranz
    MaxAnzahl = .Range("D2") 'Anzahl Werte
    If MaxAnzahl > 256 Then MaxAnzahl = 200
    ReDim a(1 To 20)
    For m = 2 To 20
        If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
            a(m - 1) = .Cells(m, 1)
        Else
            ReDim Preserve a(1 To m - 1)
            Exit For
        End If
    Next
    ReDim Preserve a(1 To UBound(a) - 1)
    Set Lösungen = New Collection
    .Range("D6") = Kombinationen(a, Zielwert, MaxAnzahl, Toleranz)
    Application.ScreenUpdating = False
    .Range("A22:IV65536").ClearContents
    n = 21
    For Each c In Lösungen
        n = n + 1
        Zielwert = 0
        For m = 1 To UBound(c)
            Zielwert = Zielwert + c(m)
        Next
        .Range(.Cells(n, 2), .Cells(n, UBound(c) + 1)) = c
        .Cells(n, 1) = Zielwert
    Next
    Application.ScreenUpdating = True
End With
End Sub

'In ein Modul

Option Explicit
Public Lösungen As Collection

Public Function Kombinationen(Elemente, Sollwert As Double, _
     Optional MaxAnzahl As Long, Optional Toleranz As Double, _
     Optional Beginn As Long, Optional ByVal x)
Dim i As Long, Summe As Double, Vergleichswert As Double
Dim k As Long, m As Long, n As Long
Dim dummy As Double, Schlüssel As String
On Error Resume Next 'Um doppelte Lösungen zu verhindern
i = UBound(x)
If i = 0 Then ReDim x(0)
If Beginn = 0 Then Beginn = 1
If MaxAnzahl = 0 Then MaxAnzahl = 50
'Ausgangselemente nach Größe sortieren
For m = 1 To UBound(Elemente)
    For n = m + 1 To UBound(Elemente)
        If Elemente(n) < Elemente(m) Then
            dummy = Elemente(m)
            Elemente(m) = Elemente(n)
            Elemente(n) = dummy
        End If
    Next
Next
For i = Beginn To UBound(Elemente)
    Do
            'Anzahl der bisher benötigten Briefmarken ermitteln
            k = UBound(x)
            'Summe der bisher gewählten Briefmarken ermitteln
            Summe = 0
            For m = 1 To k
                Summe = Summe + x(m)
            Next
            'Aktuellen Wert hinzufügen
            Vergleichswert = Summe + Elemente(i)
            'Vergleichen, ob Sollwert erreicht ist
            If Abs(Sollwert - Vergleichswert) < (0.001 + Toleranz) Then
                If UBound(x) < MaxAnzahl Then
                    'Sollwert ist erreicht, Wert hinzufügen
                    ReDim Preserve x(1 To UBound(x) + 1)
                    'Anzahl der bisher benötigten Briefmarken ermitteln
                    k = UBound(x)
                    x(k) = Elemente(i)
                    'Nach Größe sortieren, um nachher eindeutigen
                    'Schlüssel zu erzeugen
                    For m = 1 To k
                        For n = m + 1 To k
                            If x(n) < x(m) Then
                                dummy = x(m)
                                x(m) = x(n)
                                x(n) = dummy
                            End If
                        Next
                    Next
                    'Eindeutigen Schlüssel erzeugen
                    Schlüssel = ""
                    For m = 1 To k
                        For n = 1 To UBound(Elemente)
                            If x(m) = Elemente(n) Then
                                Schlüssel = Schlüssel & n
                                Exit For
                            End If
                        Next
                    Next
                    'Wenn Schlüssel schon existiert, wird Fehler
                    'ausgelöst. Lösung ist dann schon vorhanden
                    Lösungen.Add x, Schlüssel
                End If
                Exit Do 'Mit nächsthöherem Wert weiter
            End If
            If (Vergleichswert > (Sollwert + 0.001 + Toleranz)) Or _
                (UBound(x) >= MaxAnzahl) Then
                'Sollwert überschritten, zwei Marken zurück
                ReDim Preserve x(1 To UBound(x) - 2)
                Exit Do 'Mit nächsthöherem Wert weiter
            Else
                'Rekursiv aufrufen, beginnen mit nächsthöherer Marke
                Kombinationen Elemente, Sollwert, MaxAnzahl, Toleranz, i + 1, x
                'Es ist noch Luft da, Wert hinzu
                ReDim Preserve x(1 To UBound(x) + 1)
                x(UBound(x)) = Elemente(i)
            End If
    Loop
Next 'Nächsthöhere Marke probieren
Kombinationen = Lösungen.Count 'Gefundene Lösungen zurück
End Function