might try this one.
Sub GridOfNumbers2()
Dim s1 As Shape, startnum As Integer, i As Integer, ix As Integer, ti As Integer
ActiveDocument.Unit = cdrMillimeter
startnum = InputBox("Enter starting number")
ActiveDocument.BeginCommandGroup ("numbers")
Optimization = True
ti = startnum
For i = startnum To (startnum + 30) 'adjust this number to get more or less
For ix = startnum To (startnum + 21) 'adjust this number to get more or less
Set s1 = ActiveLayer.CreateArtisticText(0 + x, 290 + y, Format(ti, "000"))
s1.Fill.UniformColor.CMYKAssign 45, 45, 45, 100
s1.Outline.SetNoOutline
x = x + 40
ti = ti + 1
Next ix
x = 0
y = y - 30
Next i
Optimization = False
ActiveWindow.Refresh
End Sub