Const z& = 6000000
Sub tata1()
Dim n&, p&, x%
Dim m&, d(1 To 1000, 1 To 1)
On Error Resume Next
Randomize
For m = 1 To z
n = 0: p = p + 1
Do: n = n + 1: x = WorksheetFunction.RandBetween(0, 5): Loop While x < 1 Or 2 <= x
d(n, 1) = d(n, 1) + 1
If p Mod 10000 = 0 Then DoEvents
Next
With [D1]: .Offset(0, 0).Value = 1: .Offset(1, 0).Resize(1000, 1).Value = d: End With
End Sub