AW: hab kein 2007 owT
27.01.2011 14:43:28
Reinhard
Hallo Rudi,
Blätter sind völlig leer, in einem Standardmodul ist nachfolgender Code.
@Alifa
änder mal
Dim vSrc()
...
vSrc() = v ^ 2
in
Dim vSrc(1999)
...
vSrc(v - 1) = v ^ 2
Gruß
Reinhard
Option Explicit
Sub KombiMitArray()
Dim i As Long, u As Double, lngR As Long, lngSum As Long
Dim n As Byte, k As Byte, j As Long, s, t!, v
Dim vSrc()
t = Timer
For v = 1 To 2000
vSrc() = v ^ 2
Next
For s = 10000 To 20000
k = 2
n = 2001
u = (n / 2) * (n - 1)
ReDim vRes(k - 1)
ReDim bPos(k - 1) As Byte
For i = 1 To k
bPos(i - 1) = i
Next
Application.ScreenUpdating = False
With ActiveSheet
For i = 1 To u
lngSum = 0
For j = 0 To UBound(bPos)
vRes(j) = vSrc(bPos(j) - 1)
lngSum = lngSum + vRes(j)
Next
If lngSum = s Then
lngR = lngR + 1
.Range(.Cells(lngR, 1), .Cells(lngR, k)).Value = vRes
Cells(lngR, 3) = s
End If
Call GetComb(n, k, bPos)
Next
End With
Next
Application.ScreenUpdating = True
MsgBox "fertig in " & Round(Timer - t, 2) & " Sek "
End Sub
Sub GetComb(ByVal n As Byte, ByVal k As Byte, bPos() As Byte)
Dim i As Byte, j As Byte
i = k - 1
Do While bPos(i) >= n - k + i + 1
If i = 0 Then Exit Do
i = i - 1
Loop
bPos(i) = bPos(i) + 1
For j = i To k - 1
bPos(j) = bPos(i) + j - i
Next
End Sub