summe gegeben - Summanten gesucht

Forumthread: summe gegeben - Summanten gesucht

16.03.2005 13:22:58

david

Hallo,
gibt es eine Möglichkeit, aus einer langen Liste von Zahlen, diejedigen Zahlen zu filtern, die addiert, eine gegebene Summer ergeben?
Vielen Dank
David

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Nein, da müsstest du schon ein umfang...

16.03.2005 13:53:36

Luc
zB so...

17.03.2005 09:29:40

ingoG
AW: zB so...

17.03.2005 14:58:42

david
korrektur...

17.03.2005 16:36:51

ingoG
AW: korrektur...

21.03.2005 09:56:53

david
AW: korrektur...

21.03.2005 11:20:55

david

Nein, da müsstest du schon ein umfang...

16.03.2005 13:53:36

Luc

...reiches VBA-Programm schreiben. Wenn die Zahlen keine Potenzen zur stets gleichen Basiszahl sind, ist es nahezu unmöglich, weil auch bei stets gleicher Summandenanzahl idR mehrere Möglichkeiten existieren (bei hinreichend großer Zahlenmenge). Das Ganze ist auch eher ein mathematisches Problem.
mfG Luc :-?

zB so...

17.03.2005 09:29:40

ingoG

Hallo David,
für einige Zahlen (bis ca 30 oder 40)funzt folgendes Macro, wobei die laufzeiten immer länger werden):
die Werte stehen in spalte a und die summe in c1...
in a dürfen auch keine anderen werte stehen und sie müssen bei a1 anfangen und fortlaufend besetzt sein.
b1 sollte leer sein, da hier die summanden hin kopiert werden, die zur summe führen.
es wird momentan immer nur eine möglichkeit gefunden, theoretisch könnte man jedoch auch mehrere lösungen nacheinander suchen (mit zusätzlichem programmieraufwand)...
Gruß Ingo
PS eine Rückmeldung wäre nett...


Sub summand()
Dim kk&, ii As Double, summe As Double
Dim daten() As Double
ReDim daten1(ActiveSheet.Range("a65536").End(xlUp).Row)
ReDim daten2(ActiveSheet.Range("a65536").End(xlUp).Row)
ActiveSheet.Columns(1).Interior.ColorIndex = 0
For ii = 1 To UBound(daten2)
daten1(ii) = ActiveSheet.Range("A" & ii)
daten2(ii) = 0
Next ii
'MsgBox WorksheetFunction.Sum(daten1)
ActiveSheet.Columns("B").ClearContents
For ii = 1 To 2 ^ UBound(daten1)
summe = 0
For kk = 1 To UBound(daten1)
daten2(kk) = CLng((ii) / 2 ^ (kk - 1)) Mod 2
summe = summe + daten1(kk) * daten2(kk)
Next kk
If summe = ActiveSheet.Range("c1") Then GoTo fertig
Next ii
If summe <> ActiveSheet.Range("c1") Then Exit Sub
fertig:
For ii = 1 To UBound(daten1)
If daten2(ii) Then
ActiveSheet.Range("A" & ii).Interior.ColorIndex = 3
ActiveSheet.Range("B" & ii) = daten1(ii)
End If
Next
End Sub

AW: zB so...

17.03.2005 14:58:42

david

Danke das funktioniert schon mal sehr gut.
Nur wenn die Summanten in den ersten Zeilen hintereinander stehen, findet das Makro diese nicht. Gibt es hierfür auch eine Lösung?
Auf jeden Fall vielen Dank!
Gruß David

korrektur...

17.03.2005 16:36:51

ingoG

Hallo David,
habe noch einen Fehler behoben, der dazu geführt hat, dass bestimmte summen nicht gefunden wurden...
ausserdem wirst Du jetzt gefragt, ob du an dieser stelle weitersuchen möchtest, also eine weitere Lösung benötigst.
das zeilen/Spalten prob würde ich momentan erstmal so lösen, dass ich die werte mit kopieren, inhalte einfügen werte, transponiert in die spalte a kopiere und dann das Macro laufen lasse. (man kann das nat umprogrammieren, hab aber momentan zu wenig zeit)
ich hoffe, das hilft dir erst mal weiter...
Gruß Ingo
Option Explicit


Sub summand()
Dim kk&, ii#, summe#
Dim anfang#, Antw&
Dim daten() As Double
ReDim daten1(ActiveSheet.Range("a65536").End(xlUp).Row)
ReDim daten2(ActiveSheet.Range("a65536").End(xlUp).Row)
For ii = 1 To UBound(daten2)
daten1(ii) = ActiveSheet.Range("A" & ii)
daten2(ii) = 0
Next ii
'MsgBox WorksheetFunction.Sum(daten1)
anfang = 1
weiter:
ActiveSheet.Columns("B").ClearContents
ActiveSheet.Columns(1).Interior.ColorIndex = 0
For ii = anfang To 2 ^ UBound(daten1)
summe = 0
For kk = 1 To UBound(daten1)
daten2(kk) = Int((ii) / 2 ^ (kk - 1)) Mod 2
summe = summe + daten1(kk) * daten2(kk)
Next kk
If summe = ActiveSheet.Range("c1") Then GoTo fertig
Next ii
If summe <> ActiveSheet.Range("c1") Then Exit Sub
fertig:
For kk = 1 To UBound(daten1)
If daten2(kk) Then
ActiveSheet.Range("A" & kk).Interior.ColorIndex = 3
ActiveSheet.Range("B" & kk) = daten1(kk)
End If
Next
anfang = ii + 1
Antw = MsgBox("nächste Lösung?" & Chr(13) & "bisherige Lösung wird überschrieben", vbOKCancel, "Weiter")
If Antw = vbOK Then GoTo weiter
End Sub

AW: korrektur...

21.03.2005 09:56:53

david

Vielen Dank!
Genau so etwas hab ich mir vorgestellt. Schön hier im Forum auf so kompetente Hilfe zu treffen.
Viele Grüße David

AW: korrektur...

21.03.2005 11:20:55

david

Hallo Ingo,
wenn die Spalten länger werden funktioniert das Makro leider nicht mehr. Excel hängt sich dann auf. Ich habe eine Beispieldatei eingestellt, wie so eine Datei bei mir in der regel aussieht:
https://www.herber.de/bbs/user/19934.xls
Vielleicht findest du ja hierzu auch noch eine Lösung.
Vielen Dank!!!
Grüße David

Beliebteste Forumthreads (12 Monate)

summe gegeben - Summanten gesucht

Forumthread: summe gegeben - Summanten gesucht

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread