summe gegeben - Summanten gesucht

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: summe gegeben - Summanten gesucht von: david klink
Geschrieben am: 16.03.2005 13:22:58

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

Bild


Betrifft: Nein, da müsstest du schon ein umfang... von: Luc
Geschrieben am: 16.03.2005 13:53:36

...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 :-?


Bild


Betrifft: zB so... von: ingoG
Geschrieben am: 17.03.2005 09:29:40

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



Bild


Betrifft: AW: zB so... von: david klink
Geschrieben am: 17.03.2005 14:58:42

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


Bild


Betrifft: korrektur... von: ingoG
Geschrieben am: 17.03.2005 16:36:51

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



Bild


Betrifft: AW: korrektur... von: david klink
Geschrieben am: 21.03.2005 09:56:53

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


Bild


Betrifft: AW: korrektur... von: david klink
Geschrieben am: 21.03.2005 11:20:55

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


 Bild

Beiträge aus den Excel-Beispielen zum Thema "summe gegeben - Summanten gesucht"