excel VBA之拆分工作簿

1．根据指定列拆分成不同的工作表（标题行默认为1，根据N列拆分）

Sub拆分() '逐行复制，速度偏慢，通用性好

  Dim SplitCol As String, ColNum As Integer, HeadRows As Byte, arr, lastrow, i, ShtIndex, only As New Collection

  SplitCol = "N"  '指定拆分条件所在列。可以根据实际情况修改列标

 指定标题行数，该区域不参与拆分

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所有数据

 提取其中的不重复值

  Next i

  ShtIndex = ActiveSheet.Index  '获取当前表位置

  On Error Resume Next

  For i = 1 To only.Count

 获取与only对象中每个元素同名的工作表名（用意为判断是否存在该工作表）

 当前工作簿已存在与待拆分项目同名的工作表“" & only(i) & "”，暂无法拆分", , "友情提示": Exit Sub

  Next i

  Application.ScreenUpdating = False  '关闭屏幕更新，加快执行速度

  Application.Calculation = xlCalculationManual  '调为手动计算，加快执行速度

  For i = 1 To only.Count  '创建工作表，表的数量与表名由only对象中不重复值而定

 创建

    Sheets(Sheets.Count).Name = only(i)    '命名

 复制标题

  Next i

  Sheets(ShtIndex).Select  '返回被拆分的工作表

 逐行复制数据

 排除空值

 第一次复制，复制所有数据，仅取其格式

 第二次复制，仅复制数值

  Next i

  Application.ScreenUpdating = True  '恢复屏幕更新

  Application.Calculation = xlCalculationAutomatic  '恢复自动计算

  MsgBox "拆分完毕！", , "友情提示"

End Sub

2.转成的工作簿

Sub 工作簿拆分()

  On Error Resume Next

  Dim Pathstr As String, i As Long, ActiveWB As String

 创建文件对话框的实例

 如果在对话框中单击了"确定"

 将选定的路径赋予变量

 否则退出程序

  End With

 如果不是“\”结尾则添加“\”

  Application.ScreenUpdating = False

 记录活工作簿名

 循环所有工作表

    Sheets(i).Copy    '复制工作表到新工作簿中（忽略了参数）

 将工作簿另存，文件名由工作表名决定。而文件的后缀名则由Excel程序的版本决定

    With ActiveSheet.UsedRange    '引用已用区域

 查找“=*]*'!”，也就是检查是否存在外部引用

      FirstAddress = cell.Address    '记录第一个找到的地址

 将公式转换成值

 查找下一个

 如果未找进到则退出循环

 如果回到第一次找到的单元格则退出循环

line:

 关闭窗口

 激活待拆分的工作簿

  Next i

  Application.ScreenUpdating = True  '恢复屏幕更新

  Shell "EXPLORER.EXE " & Pathstr, vbNormalFocus  '打开文件夹

End Sub