Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
584to588
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
584to588
584to588
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

summe gegeben - Summanten gesucht

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
Anzeige
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

Anzeige
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

Anzeige
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)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige