Frage stellen

Welche Summanden bilden vorgegebene Summe?

12.1k Aufrufe
Gefragt in Tabellenkalkulation von ahorn38 Experte (3.2k Punkte)
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.

59 Antworten

0 Punkte
Beantwortet von ahorn38 Experte (3.2k Punkte)
Hallo nighty,

du wird immer besser. Bei mir funktioniert es bis zu " mittleren Problemen" einwandfrei und sogar recht schnell!!
Danke und Gruß
A.
0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi Andreas ^^

ich werde noch die cells Anweisungen in ein Array wandeln und noch ein paar Ereignisse ausschalten

das gibt dir bisl mehr Spielraum :-)

wenn ich einen aehnlichen code ueber einen beliebigen Compiler laufen lasse funktioniert er wie er soll
nur Excel vba zickt immer rum *kicher kicher*

gruss nighty
0 Punkte
Beantwortet von ahorn38 Experte (3.2k Punkte)
Ok, bin gespannt! VG A.
0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi Andres ^^

schneller bekomme ich es nicht hin glaube ich
cells Anweisungen nun im Array
und eine Sortierung
die bewirkt das zu große summanten (in bezug auf die gesamtsumme)ausgeschlossen werden
so reduziert sich x von 2 hoch x enorm

gruss nighty

Sub Summanten()
Call EventsOff
Dim Puffer As Double, GesamtSumme As Double
Dim StringPos As Long, BitIndex As Long, ZeilenIndex As Long, Zrng As Long, Lzeile As Long
Dim StringEnde As String, StringY As String, StringX As String, Puffer1 As String
Lzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
ReDim daten(0 To 1, 1 To Lzeile) As Double
ReDim ArrDat0(0) As Double
ReDim ArrDat1(0) As String
Columns("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("B2:C" & Rows.Count) = ""
GesamtSumme = 8
For Zrng = 1 To Lzeile
daten(1, Zrng) = Cells(Zrng + 1, 1)
StringX = StringX & "0"
StringEnde = StringEnde & "1"
If daten(1, Zrng) > GesamtSumme Then
Lzeile = Zrng
Exit For
End If
Next Zrng
StringY = StringX
ZeilenIndex = 1
Do
StringPos = InStrRev(StringY, "0")
StringY = Mid(StringY, 1, StringPos - 1) & "1" & Mid(StringX, StringPos + 1, Len(StringX))
For BitIndex = 1 To Lzeile
Puffer = Puffer + daten(Mid(StringY, BitIndex, 1), BitIndex)
If daten(Mid(StringY, BitIndex, 1), BitIndex) <> "0" Then Puffer1 = Puffer1 & " " & daten(Mid(StringY, BitIndex, 1), BitIndex)
Next BitIndex
If Puffer = GesamtSumme Then
ReDim Preserve ArrDat0(ZeilenIndex)
ReDim Preserve ArrDat1(ZeilenIndex)
ArrDat0(ZeilenIndex) = Puffer
ArrDat1(ZeilenIndex) = Puffer1
ZeilenIndex = ZeilenIndex + 1
End If
Puffer = 0
Puffer1 = ""
Loop While StringY <> StringEnde
ReDim Datt(ZeilenIndex - 1, 2) As Variant
Datt() = Range("C2:B" & ZeilenIndex)
For Umschieb = 1 To ZeilenIndex - 1
Datt(Umschieb, 1) = ArrDat0(Umschieb)
Datt(Umschieb, 2) = ArrDat1(Umschieb)
Next Umschieb
Range("C2:B" & ZeilenIndex) = Datt()
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
0 Punkte
Beantwortet von ahorn38 Experte (3.2k Punkte)
Hallo Nighty,

Es ist wirklich unglaublich was dir noch einfällt und was du da noch rausholst! Ich bin beeindruckt! Vielen Dank und Gruß.
A.
0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi all ^^

danke auch an alle fuer euer lob :-)

mehrfach die selben summanden sind erlaubt,da die werte sekundaer sind und die felder als solches verglichen werden
nach einer kurzen testphase(sehr kurz) wuerde ich sagen das Richtung 30 summanden der code noch funktioniert,ansonsten einfach testen
fehler sind ausgeschlossen da das duale System alle varianten einfach mit 0/1 darstellt
der code ist flexibel das er fast endlos summanden aufnehmen kann und auch alle varianten dann darstellt,hier ist Excel vba das Problem das lange Laufzeiten nicht mag
wobei natuerlich auch alle grenzen gesprengt werden und es schnell in den Trillionen Bereich geht

dann viel spass damit

gruss nighty
0 Punkte
Beantwortet von ahorn38 Experte (3.2k Punkte)
TOP!!
A.
0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi Andreas und all ^^

noch ein wenig erweitert :-)

gruss nighty

1 zeile ueberschriften

spalte A ab zeile 2 summanden

spalte B zeile 2 gesamtsumme
spalte C zeile 2 anzahl varianten,bei keiner eingabe alle varianten
spalte D zeile 2 anzahl Teilmenge bei keiner eingabe alle Teilmengen

ausgabe ab der 4 zeile

gruss nighty

Sub Summanten()
Call EventsOff
Dim Puffer As Double, GesamtSumme As Double
Dim StringPos As Long, BitIndex As Long, ZeilenIndex As Long, Zrng As Long
Dim Lzeile As Long, Umschieb As Long, AnzVar As Long, AnzTmenge As Long, AnzTmengezaehler As Long
Dim StringEnde As String, StringY As String, StringX As String, Puffer1 As String
Lzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
ReDim daten(0 To 1, 1 To Lzeile) As Double
ReDim ArrDat0(0) As Double
ReDim ArrDat1(0) As String
Columns("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
GesamtSumme = Cells(2, 2)
Range("B4:C" & Rows.Count) = ""
For Zrng = 1 To Lzeile
daten(1, Zrng) = Cells(Zrng + 1, 1)
StringX = StringX & "0"
StringEnde = StringEnde & "1"
If daten(1, Zrng) > GesamtSumme Then
Lzeile = Zrng
Exit For
End If
Next Zrng
StringY = StringX
ZeilenIndex = 1
AnzVar = Cells(2, 3)
AnzTmenge = Cells(2, 4)
Do
StringPos = InStrRev(StringY, "0")
StringY = Mid(StringY, 1, StringPos - 1) & "1" & Mid(StringX, StringPos + 1, Len(StringX))
For BitIndex = 1 To Lzeile
Puffer = Puffer + daten(Mid(StringY, BitIndex, 1), BitIndex)
If daten(Mid(StringY, BitIndex, 1), BitIndex) <> "0" Then
Puffer1 = Puffer1 & " " & daten(Mid(StringY, BitIndex, 1), BitIndex)
AnzTmengezaehler = AnzTmengezaehler + 1
End If
Next BitIndex
If Puffer = GesamtSumme Then
If AnzTmenge = AnzTmengezaehler Then
ReDim Preserve ArrDat0(ZeilenIndex)
ReDim Preserve ArrDat1(ZeilenIndex)
ArrDat0(ZeilenIndex) = Puffer
ArrDat1(ZeilenIndex) = Puffer1
ZeilenIndex = ZeilenIndex + 1
If ZeilenIndex - 1 = AnzVar Then StringY = StringEnde
End If
If AnzTmenge = 0 Then
ReDim Preserve ArrDat0(ZeilenIndex)
ReDim Preserve ArrDat1(ZeilenIndex)
ArrDat0(ZeilenIndex) = Puffer
ArrDat1(ZeilenIndex) = Puffer1
ZeilenIndex = ZeilenIndex + 1
If ZeilenIndex - 1 = AnzVar Then StringY = StringEnde
End If
End If
AnzTmengezaehler = 0
Puffer = 0
Puffer1 = ""
Loop While StringY <> StringEnde
ReDim Datt(ZeilenIndex - 1, 2) As Variant
Datt() = Range("B4:C" & ZeilenIndex + 2)
For Umschieb = 1 To ZeilenIndex - 1
Datt(Umschieb, 1) = ArrDat0(Umschieb)
Datt(Umschieb, 2) = ArrDat1(Umschieb)
Next Umschieb
Range("B4:C" & ZeilenIndex + 2) = Datt()
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
0 Punkte
Beantwortet von ahorn38 Experte (3.2k Punkte)
Hallo nighty,

hatte nicht damit gerechnet, dass es überhaupt noch weitere Verbesserungen geben kann .... aber du hast es wieder mal geschafft!! Test war einwandfrei!!
Danke und Gruß!!
A.
Seite:
...