Hi Erhard,
folgender Code spuckt in weniger als einer halben Minute 114 Lösungen
auf dem aktuellem Tabellenblatt aus:
Option Explicit
Dim pp(1 To 5040, 1 To 7) As Byte
Sub PermStart()
Const tt$ = "1234567"
Dim ii As Long, jj As Long, nn As Long
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, k5 As Long, k6 As Long, k7 As Long
Dim z1 As Long, z2 As Long, z3 As Long, z4 As Long, z5 As Long, z6 As Long, z7 As Long
z1 = 0
Perm tt, "", z1
For z1 = 1 To 5040
If pp(z1, 1) = 5 And pp(z1, 2) pp(z1, 3) And _
pp(z1, 4) > pp(z1, 5) And pp(z1, 5) > pp(z1, 6) And pp(z1, 7) = 1 Then
k1 = k1 + 1
For z2 = 1 To 5040
If pp(z2, 1) = 2 And pp(z2, 2) = 5 And pp(z2, 4) > pp(z2, 3) Then
For ii = 1 To 7
If pp(z1, ii) = pp(z2, ii) Then Exit For
Next ii
If ii = 8 Then
k2 = k2 + 1
For z3 = 1 To 5040
If pp(z3, 2) > pp(z3, 1) And pp(z3, 4) > pp(z2, 4) And _
pp(z3, 5) pp(z3, 2) And pp(z4, 3) > pp(z4, 4) And _
pp(z4, 6) > pp(z4, 7) Then
For ii = 1 To 7
If pp(z1, ii) = pp(z4, ii) Then Exit For
If pp(z2, ii) = pp(z4, ii) Then Exit For
If pp(z3, ii) = pp(z4, ii) Then Exit For
Next ii
If ii = 8 Then
k4 = k4 + 1
For z5 = 1 To 5040
If pp(z5, 1) = 6 And pp(z5, 3) > pp(z5, 4) And _
pp(z5, 4) > pp(z5, 5) And _
pp(z5, 7) > pp(z5, 6) Then
For ii = 1 To 7
If pp(z1, ii) = pp(z5, ii) Then Exit For
If pp(z2, ii) = pp(z5, ii) Then Exit For
If pp(z3, ii) = pp(z5, ii) Then Exit For
If pp(z4, ii) = pp(z5, ii) Then Exit For
Next ii
If ii = 8 Then
k5 = k5 + 1
For z6 = 1 To 5040
If pp(z6, 4) = 1 Then
For ii = 1 To 7
If pp(z1, ii) = pp(z6, ii) Then Exit For
If pp(z2, ii) = pp(z6, ii) Then Exit For
If pp(z3, ii) = pp(z6, ii) Then Exit For
If pp(z4, ii) = pp(z6, ii) Then Exit For
If pp(z5, ii) = pp(z6, ii) Then Exit For
Next ii
If ii = 8 Then
k6 = k6 + 1
For z7 = 1 To 5040
If pp(z7, 1) > pp(z6, 1) And pp(z7, 5) > pp(z7, 4) Then
For ii = 1 To 7
If pp(z1, ii) = pp(z7, ii) Then Exit For
If pp(z2, ii) = pp(z7, ii) Then Exit For
If pp(z3, ii) = pp(z7, ii) Then Exit For
If pp(z4, ii) = pp(z7, ii) Then Exit For
If pp(z5, ii) = pp(z7, ii) Then Exit For
If pp(z6, ii) = pp(z7, ii) Then Exit For
Next ii
If ii = 8 Then
k7 = k7 + 1
nn = nn + 1
For ii = 1 To 1
Cells(nn, 8) = k7
nn = nn + 1
For jj = 1 To 7
Cells(nn, jj) = pp(z1, jj)
Cells(nn + 1, jj) = pp(z2, jj)
Cells(nn + 2, jj) = pp(z3, jj)
Cells(nn + 3, jj) = pp(z4, jj)
Cells(nn + 4, jj) = pp(z5, jj)
Cells(nn + 5, jj) = pp(z6, jj)
Cells(nn + 6, jj) = pp(z7, jj)
Next jj
nn = nn + 6
If nn > 20 Then ActiveWindow.SmallScroll down:=8
Next ii
End If
End If
Next z7
End If
End If
Next z6
End If
End If
Next z5
End If
End If
Next z4
End If
End If
Next z3
End If
End If
Next z2
End If
Next z1
End Sub
Sub Perm(aa$, bb$, Ze&)
Dim ii%, jj%: jj = Len(aa)
If jj > 1 Then
For ii = 1 To jj
Perm Left(aa, ii - 1) + Right(aa, jj - ii), bb + Mid(aa, ii, 1), Ze
Next ii
Else
Ze = Ze + 1
If Ze > UBound(pp) Then Stop
For ii = 1 To 6
pp(Ze, ii) = Mid(bb, ii, 1)
Next ii
pp(Ze, 7) = aa
End If
End Sub
Viel Spaß!
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort