根据指定要求，一键拆分工作簿！
关注Excel不加班，置顶公众号
最佳人气奖：雪静，获得全套签名书+全部班级免费学。
运气奖：找不到猫的薛定谔(朋友)、sunshine、紫雪，获得函数书籍。
加卢子微信chenxilu1987
除了老学员，很少有人知道无言这个人，不过无言却是Excel不加班团队不可缺少的人物。一个协助卢子十年的人，一直在背后默默无闻。无言擅长VBA和Word，通常遇到这两类问题，卢子都扔给无言处理，术业有专攻。
好了，介绍完毕，今天来看无言写的VBA教程，换一个口味。
最近在QQ群中，多年的网友“牛省”遇到一个累人的活儿——将几万条信息根据需要的行数量拆开为多个新文件。
牛省：无言，有空吗，我这里有个活儿比较累人，需要你帮我弄个过程节省下时间。
无言：什么事情啊？
牛省：我这里有一份表，要求的根据一定的行数量保存为新的工作簿——例如我现在需要按照每500行拆分为多个文件，现在的总行数有10多万行，我让好几个同事一起分区间拆分，每个人都要用半个小时才能做好，而且保存超级慢；你帮我写个过程吧。
要求：根据指定行数量拆分保留每一个区域间的数据，并且保留原标题样式，并保存为一个新的工作簿，最好是保留原格式，因为系统导入用的。
无言：每一个区域数据指什么呢？
牛省：就是例如，按每500行，保留一次数据，那么从标题后开始的行1-500这个区间的数据和标题内容都另存为一个新的工作簿；下一个区域就从501-1000做同样操作即可。
无言：哦，好的明白了！我忙完了给你写。
现在文件夹中存在着2个文件，别无其他。
无言：过程已经写好，先看操作动画，再看代码解释。
点二维码运行，输入500，需要按多少行就输入多少，然后找到指定的工作簿，选择标题，现在标题是一行，就选择一行。
大约经过30秒钟，就生成了所有工作簿。
代码 1拆分过程代码
Sub 指定拆分行数量并另存为新文件()
‘A区
Dim Hangs As Long, MaxR As Long, ShCou AsLong
Dim BiaoT As Range, ShsCou As Long, Cou AsLong
Dim Wjlx As String, Wj_Odj
Dim Wb_Old As Workbook, Wb_New AsWorkbook, Sh As Worksheet
Dim Lj As String, New_Str As String,NewT_Str As String
Dim HouZ_Str As String, RowCou As Long
‘B区
On Error Resume Next
‘C区
Hangs = Application.InputBox("请输入需要拆分的行数量，默认1000行，最高不超1000，最低为1！", Title:="拆分行量", Default:=1000, Type:=1)
If Hangs < 1 Or Hangs > 1000 Then
If MsgBox("拆分行量超过限值，将返回默认1000行，或者选择【No】退出过程！", vbYesNo, "过程提示") = vbNo Then
Exit Sub
Else
Hangs = 10 ^ 3
End If
End If
Wjlx = "Excel 97-03版文件(*.Xls),*.Xls,Excel 07版文件(*.Xlsx),*.Xlsx,Excel文件(*.Xl*),*.Xl*"
Wj_Odj =Application.GetOpenFilename(FileFilter:=Wjlx, FilterIndex:=1, Title:="打开", MultiSelect:=False)
If Err.Number <> 0 Then Exit Sub
Set Wb_Old = Workbooks.Open(Wj_Odj)
Lj = Wb_Old.Path
HouZ_Str = StrReverse(Wb_Old.Name)
HouZ_Str = StrReverse(Left(HouZ_Str,InStr(HouZ_Str, ".")))
New_Str = Replace(Wb_Old.Name, HouZ_Str,"")
‘D区
With Wb_Old.Sheets(1)
.Activate
Set BiaoT =Application.InputBox("请选择标题范围，选择整行或数行！", "标题范围", .Rows("1:4").Address, Type:=8)
If BiaoT Is Nothing Then MsgBox "您为选择区域，过程将退出！": Exit Sub
MaxR = .Cells(Rows.Count, 1).End(xlUp).Row
ShCou = IIf((MaxR - 1 Mod Hangs) = 0,(MaxR - 1) / Hangs, (MaxR - 1) \ Hangs + 1)
Cou = BiaoT.Rows.Count
End With
‘E区
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For ShsCou = 1 To ShCou
NewT_Str = Lj & "\" &New_Str & " No " & Format((ShsCou - 1) * Hangs + 1,"000000000") & HouZ_Str
ActiveWorkbook.SaveCopyAs NewT_Str
Set Wb_New =Workbooks.Open(NewT_Str) '前台打开
With Wb_New.Sheets(1)
.Activate
If ShsCou = 1 Then
RowCou = MaxR - Hangs -BiaoT.Rows.Count
.Cells(Cou + 1,1).Offset(Hangs).Resize(RowCou).EntireRow.Clear
Else
RowCou = MaxR - Hangs -BiaoT.Rows.Count
.Cells(Cou + 1,1).Offset(Hangs).Resize(Rows.Count - Cou - Hangs).EntireRow.Clear
RowCou = Hangs * (ShsCou - 1)
.Cells(BiaoT.Rows.Count + 1,1).Resize(RowCou).EntireRow.Delete
End If
Wb_New.Close SaveChanges:=True
Cou = Cou + Hangs '行量计数器
End With
Next ShsCou
‘F区
Wb_Old.Close SaveChanges:=False '关闭源工作簿
Application.ScreenUpdating = True
MsgBox New_Str & "文件已经按 " & Hangs & "行拆分为" & ShsCou & "个独立的文件！" _
& vbCr & "该过程将关闭Excel，请再次打开Excel查看！"
Application.Quit '关闭Excel
End Sub
代码说明以及源文件下载：
https://pan.baidu.com/s/1Fxq0NUWRaoc02LDnrwnhlg
学习Excel或其Office组件程序的VBA编程，入门都先通过录制简单的宏过程，再通过离线或在线帮助对所录制的方法/属性等进行学习，最重要的一点还是要通过工作或兴趣来拾取对学习的兴趣。
在最困难的时候，你是如何熬过来的？
作者：卢子，清华畅销书作者，《Excel效率手册 早做完，不加班》系列丛书创始人，个人公众号：Excel不加班（ID：Excelbujiaban）
请把「Excel不加班」推荐给你的朋友