适用于对一些票据啊什么的自动编号。
如有需要可以联系我，我可以帮忙修改下。
PS:计时调用了DLL，VBA里面没找到ms的计时方法。
Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
Sub 编号1() '52pojie.com
Dim i As Integer
Dim j As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim t As Long
Dim z As String
Rows("11:" & CStr(Rows.Count)).Delete
i = 0
MsgBox ("系统最后会将打印纵向列调整为一页并水平居中，并没10张券添加一个分页符，有问题联系，如果行高不合适，请调整预留第一组行高。")
Application.ScreenUpdating = False
a = InputBox("请输入起始编号")
b = InputBox("请输入结束编号,系统将自动调整为10的倍数")
If a > b Then
a = a + b
b = a - b
a = a - b
End If
MsgBox ("系统开始制作表格，可能会系统假死，请不要对电脑进行操作，如时间过久，则不正常，联系。")
t = timeGetTime()
Do While (b - a + 1) Mod 10 <> 0
b = b + 1
Loop
c = b - a
For i = 11 To c / 2 * 10 Step 10
Rows("1:10").Copy Cells(i, 1)
Next
i = a
For j = 1 To c / 2 * 10 Step 10
Cells(j, 5) = "编号：" & Choose(5 - Len(CStr(i)), "0", "00", "000", "0000") & i
i = i + 1
Cells(j, 11) = "编号：" & Choose(5 - Len(CStr(i)), "0", "00", "000", "0000") & i
i = i + 1
Next
z = "第一循环用时" & CStr((timeGetTime() - t)) & Chr(13)
i = 1
Do While i * 10 <= c
Rows(i * 50 + 1).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
i = i + 1
Loop
z = z + "第一、二循环用时" & CStr((timeGetTime() - t)) & "单位毫秒"
MsgBox (z)
Debug.Print (z)
Application.ScreenUpdating = ture
ActiveSheet.PageSetup.FitToPagesWide = 1
ActiveSheet.PageSetup.CenterVertically = True
End Sub 'iaixiang.com