最近在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 代码说明以及源文件下载： 学习Excel或其Office组件程序的VBA编程，入门都先通过录制简单的宏过程，再通过离线或在线帮助对所录制的方法/属性等进行学习，最重要的一点还是要通过工作或兴趣来拾取对学习的兴趣。 在最困难的时候，你是如何熬过来的？ 作者：卢子，清华畅销书作者，《Excel效率手册 早做完，不加班》系列丛书创始人，个人公众号：Excel不加班（ID：Excelbujiaban） |
|
|
