Bestimmte Kombinationen 4 aus 40
08.07.2013 01:40:17
Erich
Hi Erhard,
die folgende Prozedur gibt über 1,25 Mio. Lösungen aus:
Option Explicit
Sub aVierMalVier()
Dim arA, arE(), tSum As Integer, zz As Long, nn As Long, cc As Long, gg As Long
Dim ii As Byte, jj As Byte, kk As Byte, mm As Byte, tt As Byte, pp As Byte
Const xAnz As Byte = 40
Const xSum As Integer = 490
arA = Application.Transpose(Cells(1, 1).Resize(xAnz))
ReDim arE(1 To 4, 1 To 100)
For ii = 1 To xAnz
For jj = ii + 1 To xAnz
If ii jj Then
If arA(ii) + arA(jj) >= xSum - 2 Then Exit For
For kk = jj + 1 To xAnz
If ii kk And jj kk Then
If arA(ii) + arA(jj) + arA(kk) >= xSum - 1 Then Exit For
For mm = kk + 1 To xAnz
If ii mm And jj mm And kk mm Then
tSum = arA(ii) + arA(jj) + arA(kk) + arA(mm)
If tSum = xSum Then ' Treffer
zz = zz + 1
If zz > UBound(arE, 2) Then ReDim Preserve _
arE(1 To UBound(arE), 1 To 2 * UBound(arE, 2))
arE(1, zz) = arA(ii)
arE(2, zz) = arA(jj)
arE(3, zz) = arA(kk)
arE(4, zz) = arA(mm)
DoEvents
ElseIf tSum > xSum Then
Exit For
End If
End If
Next mm
End If
Next kk
End If
Next jj
Next ii
Cells(1, 3).Resize(UBound(arE, 2), UBound(arE)) = Application.Transpose(arE)
arA = Cells(1, 3).Resize(zz, 4)
ReDim arE(1 To 100000, 1 To 16)
cc = 8
For ii = 1 To zz - 3
For jj = ii + 1 To zz - 2
For tt = 1 To 4
For pp = 1 To 4
If arA(jj, tt) = arA(ii, pp) Then Exit For
Next pp
If pp 4 Then
For kk = jj + 1 To zz - 1
For tt = 1 To 4
For pp = 1 To 4
If arA(kk, tt) = arA(ii, pp) Then Exit For
If arA(kk, tt) = arA(jj, pp) Then Exit For
Next pp
If pp 4 Then
For mm = kk + 1 To zz
For tt = 1 To 4
For pp = 1 To 4
If arA(mm, tt) = arA(ii, pp) Then Exit For
If arA(mm, tt) = arA(jj, pp) Then Exit For
If arA(mm, tt) = arA(kk, pp) Then Exit For
Next pp
If pp 4 Then ' Treffer
If nn >= 100000 Then
Cells(gg * 100000 + 1, cc).Resize( _
UBound(arE), UBound(arE, 2)) = arE
ReDim arE(1 To 100000, 1 To 16)
If gg > 8 Then
gg = 0
cc = cc + 17
Else
gg = gg + 1
End If
nn = 0
End If
nn = nn + 1
For tt = 1 To 4
arE(nn, tt) = arA(ii, tt)
arE(nn, 4 + tt) = arA(jj, tt)
arE(nn, 8 + tt) = arA(kk, tt)
arE(nn, 12 + tt) = arA(mm, tt)
Next tt
End If
Next mm
End If
Next kk
End If
DoEvents
Next jj
Application.StatusBar = CStr(ii) & " " & _
CStr(nn + gg * 100000 + Int(cc / 17) * 1000000)
Next ii
If nn > 0 Then Cells(gg * 100000 + 1, cc).Resize(UBound(arE), UBound(arE, 2)) = arE
Application.StatusBar = False
End Sub
Die Idee:
Zunächst werden aus den 40 Zahlen alle Vierer-Gruppen ermittelt, deren Summe 490 ist.
Das sind im Beispiel (39 Zahlen wie von dir vorgegeben und als 40. die 425 von mir dazugelogen)
185 Kombinationen (1+2+130+357 bis 85+125+130+150).
Im zweiten Schritt werden dann aus diesen 185 jeweils vier Vierer-Gruppen ausgewählt.
Treffer sind die Kombinationen, bei denen insgesamt keine Zahl doppelt vorkommt.
Die Ausgabe erfolgt etappenweise alle 100.000 Treffer, jeweils max. 1 Mio. untereinander.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich