gibt es eine Möglichkeit, aus einer langen Liste von Zahlen, diejedigen Zahlen zu filtern, die addiert, eine gegebene Summer ergeben?
Vielen Dank
David
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
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