萌新求助，关于如何快速按顺序填充数字到表格中

运行这个程序需要60多秒
新建一个工作表，然后输出你想要的内容
主要时间浪费在合并单元格上
************************
直接在你原始的表格上循环这个方法我没试验，不知道要多长时间
Sub 十万份()
Dim arr As Variant
Dim i As Long, j As Long, n As Long
ReDim arr(1 To 60000, 1 To 10)
t = Timer
For i = 1 To 60000 Step 3
For j = 1 To 9 Step 2
arr(i, j) = "Receive Voucher"
Next j
For j = 1 To 9 Step 2
arr(i + 1, j) = "Name"
Next j
For j = 2 To 10 Step 2
arr(i + 1, j) = "No."
Next j
For j = 2 To 10 Step 2
n = n + 1
arr(i + 2, j) = Format(n, "000000")
Next j
Next i
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "十万份"
Range("a1").Resize(60000, 10) = arr
For i = 1 To 60000 Step 3
For j = 1 To 9 Step 2
Range(Cells(i, j), Cells(i, j + 1)).Merge
Next j
Next i
Range("a1:j60000").Borders.LineStyle = 1
MsgBox "程序运行了" & Timer - t & "秒"
End Sub

加了一句话，之前没注意000001这个格式
*******************************************************
Sub 十万份()
Dim arr As Variant
Dim i As Long, j As Long, n As Long
ReDim arr(1 To 60000, 1 To 10)
t = Timer
For i = 1 To 60000 Step 3
For j = 1 To 9 Step 2
arr(i, j) = "Receive Voucher"
Next j
For j = 1 To 9 Step 2
arr(i + 1, j) = "Name"
Next j
For j = 2 To 10 Step 2
arr(i + 1, j) = "No."
Next j
For j = 2 To 10 Step 2
n = n + 1
arr(i + 2, j) = Format(n, "000000")
Next j
Next i
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "十万份"
Range("a1").Resize(60000, 10).NumberFormatLocal = "@"
Range("a1").Resize(60000, 10) = arr
For i = 1 To 60000 Step 3
For j = 1 To 9 Step 2
Range(Cells(i, j), Cells(i, j + 1)).Merge
Next j
Next i
Range("a1:j60000").Borders.LineStyle = 1
MsgBox "程序运行了" & Timer - t & "秒"
End Sub

A3=TEXT(REPT(MOD(ROW(A1),3)+(ROW(A3)/3-1)*5+COLUMN()/2-1,ISEVEN(COLUMN())),"000000")