Sub recopier_factorielle2()
Dim Tbl(), i As Long, y As Byte, x As Long
Dim Tablo, N As Long, wsk As Worksheet, j As Long, K As Long
Tbl = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
'Effacement des feuilles
Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
Application.DisplayAlerts = True
Range("a:a").Clear
Application.ScreenUpdating = False
y = UBound(Tbl) + 1
x = Application.WorksheetFunction.Fact(y)
Set wsk = Sheets("Feuil1")
i = 1
Do
If i + y - 1 > Rows.Count Then
K = 0
Do
If i > Rows.Count Then
Sheets.Add after:=wsk
Set wsk = ActiveSheet
i = 1
End If
K = K + 1
wsk.Cells(i, 1) = K
i = i + 1
Loop Until K = y
Application.ScreenUpdating = True
DoEvents
Application.ScreenUpdating = False
Else
wsk.Range("a" & i).Resize(y, 1).Value = Application.Transpose(Tbl)
i = i + y
End If
N = N + y
Loop Until N >= x
Application.ScreenUpdating = True
MsgBox "c'est fini !"
End Sub