Sub Arrangements()
Dim dif, dossier$, nom$, dur#, col%, t()
Dim a, b, c, d, e, f, g, h, n1, n2, n3, n4, n5, n6, n7
Dim x1$, x2$, x3$, x4$, x5$, x6$, x7$, n&, total&
dif = 6 'nombre de chiffres différents
dossier = ThisWorkbook.Path & "\Arrangements\"
If Dir(dossier, vbDirectory) = "" Then MkDir dossier 'création du dossier
nom = Dir(dossier & "Mio*.xls*")
While nom <> ""
Kill dossier & nom 'vidage du dossier
nom = Dir
Wend
If dif > 8 Then Exit Sub 'sécurité
dur = Now
col = 1
ReDim t(1 To 50000, 1 To 20) 'base 1
Feuil1.[B1:C1] = ""
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For a = 0 To 9
For b = 0 To 9
n1 = 1 - (a <> b)
x1 = a & b
If n1 < dif - 6 Then GoTo 1
For c = 0 To 9
n2 = n1 - (InStr(x1, c) = 0)
x2 = x1 & c
If n2 < dif - 5 Then GoTo 2
For d = 0 To 9
n3 = n2 - (InStr(x2, d) = 0)
x3 = x2 & d
If n3 < dif - 4 Then GoTo 3
For e = 0 To 9
n4 = n3 - (InStr(x3, e) = 0)
x4 = x3 & e
If n4 < dif - 3 Then GoTo 4
For f = 0 To 9
n5 = n4 - (InStr(x4, f) = 0)
x5 = x4 & f
If n5 < dif - 2 Then GoTo 5
For g = 0 To 9
n6 = n5 - (InStr(x5, g) = 0)
x6 = x5 & g
If n6 < dif - 1 Then GoTo 6
For h = 0 To 9
n7 = n6 - (InStr(x6, h) = 0)
x7 = x6 & h
If n7 < dif Then GoTo 7
n = n + 1
t(n, col) = x7
If n = 50000 Then
total = total + n
n = 0: col = col + 1
If total Mod 1000000 = 0 Then
col = 1
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
[A1:T50000].NumberFormat = "@"
[A1:T50000].HorizontalAlignment = xlCenter
[A1:T50000] = t
ReDim t(1 To 50000, 1 To 20) 'RAZ
nom = "Mio " & Format(total / 1000000, "00") & " - "
Feuil1.[B1] = nom & [A1]
ActiveSheet.Name = nom & [A1]
ActiveWorkbook.SaveAs dossier & nom & [A1]
ActiveWorkbook.Close
Feuil1.[C1] = Now - dur
Application.ScreenUpdating = True
DoEvents
End If
End If
7 Next h
6 Next g
5 Next f
4 Next e
3 Next d
2 Next c
1 Next b
Next a
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
[A1:T50000].NumberFormat = "@"
[A1:T50000].HorizontalAlignment = xlCenter
[A1:T50000] = t
ActiveSheet.Name = nom & [A1]
ActiveWorkbook.SaveAs dossier & nom & [A1]
ActiveWorkbook.Close
Feuil1.[B1] = total + n: Feuil1.[C1] = Now - dur
Application.ScreenUpdating = True
DoEvents
MsgBox total + n & " arrangements" & vbLf & _
"Durée " & Format(Now - dur, "hh:mm:ss")
End Sub
Sub x10_08d6()
Dim i&, j&, k&, l&, m&, n&, o&, p&, x&, y&, b(9) As Boolean, v$(613199, 0), chemin$
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
chemin = ThisWorkbook.Path & "\" & Split(ThisWorkbook.Name, ".")(0) & "_x10_08d6" & "\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
For i = 0 To 9
With Application: .DisplayAlerts = False: Workbooks.Add xlWBATWorksheet: ActiveWorkbook.SaveAs chemin & i: .DisplayAlerts = False: End With
x = 0: y = 0
For j = 0 To 9
For k = 0 To 9: For l = 0 To 9: For m = 0 To 9: For n = 0 To 9: For o = 0 To 9: For p = 0 To 9
b(i) = True: b(j) = True: b(k) = True: b(l) = True: b(m) = True: b(n) = True: b(o) = True: b(p) = True
If b(0) + b(1) + b(2) + b(3) + b(4) + b(5) + b(6) + b(7) + b(8) + b(9) < -5 Then v(x, 0) = i & j & k & l & m & n & o & p: x = x + 1
Erase b
Next p, o, n, m, l, k
ActiveSheet.[A1].Offset(, y).Resize(x, 1).Value = v: Erase v: x = 0: y = y + 1: DoEvents
Next j
ActiveWorkbook.Close True
Next i
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub
Cela dit, mis à part le plaisir de faire chauffer les machines, j'ai toujours autant de mal à comprendre l'intérêt de ce genre de bricolage...
nombre minimum de chiffres distincts | nombre d'arrangements | taille du dossier de sortie | temps d'exécution |
=============== | =============== | =============== | =============== |
8 | 1 814 400 | 15,4 Mo | 45 s |
7 | 18 748 800 | 157 Mo | 3 min 45 s |
6 | 58 968 000 | 492 Mo | 10 min |
5 | 90 720 000 | 750 Mo | 15 min |
(...)
Votre ordinateur Roger est plus rapide que le mien.
(...)
For b = 0 To 9
n1 = 1 - (a <> b)
x1 = a & b
If n1 < dif - 6 Then GoTo 1
'code
1: Next b
For b = 0 To 9
n1 = 1 - (a <> b)
x1 = a & b
If n1 >= dif - 6
'code
Next b
Quant à moi, compte tenu que je ne vois pas l'intérêt de ce travail, je ne chercherai pas à optimiser mon code, d'autant plus que le demandeur semble se ficher complètement des réponses que nous apportons
#3il faut vous armer de patience, il y a beaucoup d'arrangements !!!
#4j'ai eu le message "Mémoire insuffisante etc".
Il faudrait un ordi plus puissant.
Au total on voit qu'il y a environ 60 millions d'arrangements.
et je ne parle pas des codes, ni de la qualité du Mega Barbatruc...Si l'on arrivait à lister les 60 Mio d'arrangements le fichier pèserait environ 500 Mio d'octets