Sub Arrangements()
Dim dur#, dif As Byte, dossier$, col%, t(), dico As Object
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte
Dim f As Byte, g As Byte, h As Byte, arr, i As Byte, n&, total&, nom$
dur = Now
dif = 6 'nombre de chiffres différents
dossier = ThisWorkbook.Path & "\Arrangements\"
If Dir(dossier, vbDirectory) = "" Then MkDir dossier 'création du dossier
col = 1
ReDim t(1 To 50000, 1 To 20) 'base 1
Set dico = CreateObject("Scripting.Dictionary")
Feuil1.[B1:C1] = ""
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For a = 0 To 9
For b = 0 To 9
For c = 0 To 9
For d = 0 To 9
For e = 0 To 9
For f = 0 To 9
For g = 0 To 9
For h = 0 To 9
arr = Array(a, b, c, d, e, f, g, h)
dico.RemoveAll
For i = 0 To 7
dico(arr(i)) = ""
If dico.Count = dif Then
n = n + 1
t(n, col) = Join(arr, "")
If n = 50000 Then
total = total + n
n = 0: col = col + 1
End If
If (total + n) 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
Exit For
End If
Next i, h, g, f, e, d, c, b, a
Application.ScreenUpdating = True
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