excel VBA之拆分工作簿.docxVIP

分两步进行拆分，先根据指定列拆分成不同的工作表，再把工作表转成独立的工作簿。注意拆分时，将身份证转成文本格式。 1．根据指定列拆分成不同的工作表（标题行默认为1，根据N列拆分） Sub拆分() 逐行复制，速度偏慢，通用性好 Dim SplitCol As String, ColNum As Integer, HeadRows As Byte, arr, lastrow, i, ShtIndex, only As New Collection SplitCol = N 指定拆分条件所在列。可以根据实际情况修改列标 HeadRows = 1 指定标题行数，该区域不参与拆分 If HeadRows = ActiveSheet.UsedRange.Rows.Count Then Exit Sub 如果指定的标题行大于已用区域行数则退出程序 ColNum = Cells(1, SplitCol).Column 将列标转换成数字 lastrow = ActiveSheet.UsedRange.Rows.Count 获取当前表已用区域的行数 arr = Range(Cells(HeadRows + 1, SplitCol), Cells(lastrow, SplitCol)).Value 将拆分列的数据赋与变量arr On Error Resume Next For i = 1 To lastrow - HeadRows 遍历arr所有数据 提取其中的不重复值 If Len(arr(i, 1)) 0 Then only.Add CStr(arr(i, 1)), CStr(arr(i, 1)) Next i ShtIndex = ActiveSheet.Index 获取当前表位置 On Error Resume Next For i = 1 To only.Count Debug.Print Sheets(only(i)).Name 获取与only对象中每个元素同名的工作表名（用意为判断是否存在该工作表） If err = 0 Then MsgBox 当前工作簿已存在与待拆分项目同名的工作表“ only(i) ”，暂无法拆分, 64, 友情提示: Exit Sub err.Clear Next i Application.ScreenUpdating = False 关闭屏幕更新，加快执行速度 Application.Calculation = xlCalculationManual 调为手动计算，加快执行速度 For i = 1 To only.Count 创建工作表，表的数量与表名由only对象中不重复值而定 Sheets.Add After:=Sheets(Sheets.Count) 创建 Sheets(Sheets.Count).Name = only(i) 命名 Sheets(ShtIndex).Rows(1: HeadRows).Copy Sheets(Sheets.Count).Cells(1, 1) 复制标题 Next i Sheets(ShtIndex).Select 返回被拆分的工作表 For i = HeadRows + 1 To lastrow 逐行复制数据 If Len(Cells(i, SplitCol)) 0 Then 排除空值 With Sheets(Cells(i, SplitCol).Text).UsedRange.Rows(Sheets(Cells(i, SplitCol).Text).UsedRange.Rows.Count + 1) Rows(i).Copy .Cells(1) 第一次复制，复制所有数据，仅取其格式 .Cells = Rows(i : i).Value 第二次复制，仅复制数值 End With End If Next i Application.ScreenUpdating = True 恢复屏幕更新 Application.Calculation = xlCalculationAutomatic 恢复自动计算 MsgBox 拆分完毕！, 64, 友情提示 End Sub 2.转成独立的工作簿 Sub 工作簿拆分() On Error Resume Next Dim Pathstr As String, i As Long, ActiveWB As String With