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