Welche Summanden bilden vorgegebene Summe?

Question

Hallo,

ich habe eine Zahlenreihe und möchte ermitteln welche Summanden aus dieser Reihe eine vorgegebene Summe 272,29 bilden (ggf. mehrere Möglichkeiten). Z.Bsp:

[list]A 15,00 272,29
B 17,85
C 17,85
D 107,10
E 96,99
F 46,00
G 98,00
H 64,00
I 180,00
J 35,50
K 51,00
L 38,50
M 90,00
N 30,00
O 38,00
P 56,00
Q 16,66
R 15,00
S 35,50
T 50,00
U 55,93
V 126,00
W 120,00
X 51,00
Y 51,00
Z 42,00
AA 115,50
AB 30,35
A 67,00
C 75,00
AD 42,25
AE 62,48
AF 52,00
AG 107,10
AH 55,00
AI 294,53
2446,09
[/list]
Ich kann mir eigentlich nur ineinander geschachtelte Schleifen vorstellen die alle Kombinationen prüfen müssten, was allerdings sehr schnell einen erheblichen Aufwand bedeutet. Hat jemand einen guten Tipp wie man die Sache angehen könnte?
Danke und Gruß A.

Answer 1

hi Andreas und all ^^

besser bekomme ich es leider nicht hin

schrecklich langsam und fuehrt bei entsprechender anzahl der summanten zum absturz

gruss nighty

Sub Summanten()
Application.ScreenUpdating = False
Range("B:C") = ""
Dim BinärIndex As Double, Puffer As Double
Dim BitIndex As Long, ZeilenIndex As Long, Zrng As Long, Lzeile As Long
Dim Puffer1 As String, Bdat As String
Lzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
ReDim daten(0 To 1, 1 To Lzeile) As Double
ZeilenIndex = 1
For Zrng = 1 To Lzeile
daten(1, Zrng) = Cells(Zrng + 1, 1)
Next Zrng
For BinärIndex = 1 To 2 ^ Lzeile
Bdat = dec2bin(BinärIndex)
If Len(Bdat) < Lzeile Then
For Zrng = 1 To Lzeile - Len(Bdat)
Bdat = "0" & Bdat
Next Zrng
End If
For BitIndex = 1 To Lzeile
Puffer = Puffer + daten(Mid(Bdat, BitIndex, 1), BitIndex)
If daten(Mid(Bdat, BitIndex, 1), BitIndex) <> "0" Then Puffer1 = Puffer1 & " " & daten(Mid(Bdat, BitIndex, 1), BitIndex)
Next BitIndex
'Die gewünschte gesamtsumme,zur zeit die 4
If Puffer = 8 Then
ZeilenIndex = ZeilenIndex + 1
Cells(ZeilenIndex, 2) = Puffer
Cells(ZeilenIndex, 3) = Puffer1
End If
Puffer = 0
Puffer1 = ""
Next BinärIndex
Application.ScreenUpdating = True
End Sub

Function dec2bin(ByVal lngZahl As Long) As String
If lngZahl > 0 Then dec2bin = dec2bin(lngZahl \ 2) & IIf(lngZahl Mod 2, "1", "0")
End Function

Answer 2

Hi All,

@Nighty Zunächst mal Gratulation, dass du so ein komplexes Thema in so wenigen Codezeilen darstellen kannst. Ich muss leider zugeben, dass selbst ich noch nicht so ganz verstanden habe, was da genau passiert. Respekt vor deiner Programmierkunst.

@Andreas Ich bin natürlich auch nicht ganz untätig. Allerdings lässt sich das Problem aus AW 19 nicht so leicht beheben, wie man zunächst vermuten könnte. Jedweder Versuch hat bisher weitere Probleme nach sich gezogen. Daher habe ich mich entschlossen, mein Tool komplett neu aufzubauen. Ich habe in den letzten Jahren nochmal Einiges dazu gelernt und bin nun in der Lage meinen Code erheblich übersichtlicher zu gestalten. Allerdings bin ich, wie bereits erwähnt, beruflich extrem stark zeitgebunden, sodass ich nur an den Wochenenden Gelegenheit habe, daran weiterzubasteln. Kann also noch ein bisschen dauern, denke aber, in ein paar Wochen ein verbessertes Update präsentieren zu können, welches noch besser deinem ursprünglichen Anliegen entspricht. Hoffe es ist nicht ganz so dringlich.

Positiv: Nighty und ich haben zwei unterschiedliche Herangehensweisen, dadurch lassen sich die Ergebnisse gut vergleichen um auf beiden Seiten weitere Bugs aufzudecken.

L.G. Mr. K.

Answer 3

Hallo,

ich kann mich dem Lob von Mr.K. nur anschließen!! Bei kleineren Zahlenreihen funktioniert der Code einwandfrei, Probleme ergeben sich wenn mehr als 20 Zahlen zur Auswahl stehen. Obwohl der Code nur wenige Zeilen hat, ist er unwahrscheinlich leistungsfähig, allerdings fehlt mir hier noch einiges an Wissen, um alles zu versehen.... :-(.
Mit über 40 Einträgen hat sich die Sache ja ganz schön entwickelt und wenn Mr. K. auch noch weiterknobelt, mal sehen wo wir landen.
Danke euch und Gruß
A.

Answer 4

hi all ^^

bischen tricksen geht noch ^^

spalte a wird sortiert und größere summen ausgeschlossen
so ist der Excel Tod hinausgezoegert

gruss nighty

GesamtSumme = 8 ist anzupassen

Sub Summanten()
Application.ScreenUpdating = False
Columns("A:A").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("B2:C" & Rows.Count) = ""
Dim BinärIndex As Double, Puffer As Double, GesamtSumme As Double
Dim BitIndex As Long, ZeilenIndex As Long, Zrng As Long, Lzeile As Long
Dim Puffer1 As String, Bdat As String
GesamtSumme = 8
Lzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
ReDim daten(0 To 1, 1 To Lzeile) As Double
For Zrng = 1 To Lzeile
daten(1, Zrng) = Cells(Zrng + 1, 1)
If daten(1, Zrng) > GesamtSumme Then
Lzeile = Zrng
Exit For
End If
Next Zrng
ZeilenIndex = 1
For BinärIndex = 1 To 2 ^ Lzeile
Bdat = dec2bin(BinärIndex)
If Len(Bdat) < Lzeile Then
For Zrng = 1 To Lzeile - Len(Bdat)
Bdat = "0" & Bdat
Next Zrng
End If
For BitIndex = 1 To Lzeile
Puffer = Puffer + daten(Mid(Bdat, BitIndex, 1), BitIndex)
If daten(Mid(Bdat, BitIndex, 1), BitIndex) <> "0" Then Puffer1 = Puffer1 & " " & daten(Mid(Bdat, BitIndex, 1), BitIndex)
Next BitIndex
If Puffer = GesamtSumme Then
ZeilenIndex = ZeilenIndex + 1
Cells(ZeilenIndex, 2) = Puffer
Cells(ZeilenIndex, 3) = Puffer1
End If
Puffer = 0
Puffer1 = ""
Next BinärIndex
Application.ScreenUpdating = True
End Sub

Function dec2bin(ByVal lngZahl As Long) As String
If lngZahl > 0 Then dec2bin = dec2bin(lngZahl \ 2) & IIf(lngZahl Mod 2, "1", "0")
End Function

Answer 5

Hallo nigbhty

jetzt kriege ich gar keine Ausgabe mehr, auch nicht bei kurzen Zahlenreihen.....
15
16,66
17,85
17,85
30
35,5
35,5
38
38,5
Gesucht war 50,5=35,5+15
Gruß A.

Answer 6

Hallo Andreas,

Bin der Meinung, dass der Solver eine korrekte Arbeit abliefert, habe es mir wie in Antwort 2 (Solver) @M.O. beschrieben bei 9 Zahlen angeschaut (lt. AW45) und es hat innerhalb einer Sekunde das richtige Ergebnis gebracht.

Sollten die Zahlen aber nicht übereinstimmen, kommen jedoch verrückte Ergebnisse heraus, so, dass Teilbeträge wild zugeordnet werden, aber im Endeffekt die Summe sehr wohl übereinstimmt.

Bei 37 Zahlen habe ich es auch versucht, der Solver hat sich einen abgerackert und ich hatte das Gefühl, dass das Ergebnis extrem lange gebraucht hätte und habe ich nach einiger Zeit den Vorgang auf Anfrage des Solvers abgebrochen.

Ich glaube, ob mit oder ohne VBA die Rechenleistung ist die gleiche und die ist enorm.

Als Buchhalter drängt sich für mich die Frage auf, warum sollen die Zahlen erst im Nachhinein (Sammelüberweisung>AW19) zugeteilt werden und nicht schon vorher, ohne an die Grenzen des machbaren gehen zu müssen.


Gruß
Paul1

Answer 7

hi paul1 ^^

das sind 31 374 389 534 727 varianten :-)

gruss nighty

Answer 8

Hallo nighty,

Das kann ich mir vorstellen ist ein Wahnsinn, darum habe ich ja geschrieben, daran weiterzuarbeiten wären leere Kilometer.

schönen Tag noch

Gruß Paul

Answer 9

Hallo zusammen,

danke für Eure Hilfe und Kommentare! Hat mir alles sehr geholfen. Mit dem Solver und mit dem Code (für kleinere Probleme) komme ich auch gut zurecht.
Danke, dass ihr euch alle mit soviel Aufwand und Mühe um mein "kleines" Problem gekümmert habt!!!!!!!
Viele Grüße A.

Answer 10

hi all ^^

eine variante ohne grosse zahlen :-)
stuerzt bei mir aber auch ab :-(

gruss nighty

Sub Summanten()
Application.ScreenUpdating = False
Range("B2:C" & Rows.Count) = ""
Dim Puffer As Double, GesamtSumme As Double
Dim BitIndex As Long, ZeilenIndex As Long, Zrng As Long, Lzeile As Long
Dim Puffer1 As String, Bdat As String
GesamtSumme = 12
Lzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
ReDim daten(0 To 1, 1 To Lzeile) As Double
For Zrng = 1 To Lzeile
daten(1, Zrng) = Cells(Zrng + 1, 1)
StringX = StringX & "0"
StringEnde = StringEnde & "1"
Next Zrng
StringY = StringX
ZeilenIndex = 1
Do
For StringPos = Len(StringX) To 1 Step -1
If Mid(StringY, StringPos, 1) = "0" Then
StringY = Mid(StringY, 1, StringPos - 1) & "1" & Mid(StringX, StringPos + 1, Len(StringX))
Exit For
End If
Next StringPos
Bdat = StringY
For BitIndex = 1 To Lzeile
Puffer = Puffer + daten(Mid(Bdat, BitIndex, 1), BitIndex)
If daten(Mid(Bdat, BitIndex, 1), BitIndex) <> "0" Then Puffer1 = Puffer1 & " " & daten(Mid(Bdat, BitIndex, 1), BitIndex)
Next BitIndex
If Puffer = GesamtSumme Then
ZeilenIndex = ZeilenIndex + 1
Cells(ZeilenIndex, 2) = Puffer
Cells(ZeilenIndex, 3) = Puffer1
End If
Puffer = 0
Puffer1 = ""
Loop While StringY <> StringEnde
Application.ScreenUpdating = True
End Sub