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
