1、如下图是某年级两个班级成绩表，现在我们想要按照班级的不同将此工作表拆分为两个。
2、全选表格区域，然后同时按下Alt+F11
3、点击sheet1选项，然后在右边空白区域录入vba代码
4、点击【运行】，选择【运行宏】或者直接按下F5运行vba程序
5、在弹出对话框内输入A，然后点击【确定】
6、录入标题行数1，然后点击【确定】就可以完成了
7、完成效果如下图，最后跟大家分享一下本文这里使用的vba代码，如有需要可以复制粘贴使用。'激活工作表事件'激活工作表，写入除目录外所有表名'作者：帮忙做Excel，请百度方方格子'------------------------------------------Sub 拆分本表() '逐行复制，速度偏慢，通用性好Dim SplitCol As String, ColNum As Integer, HeadRows As ByteDim arr, lastrow, i, ShtIndexDim onlySet only = CreateObject("scripting.dictionary") 'Set only = New Collection'-------------'指定拆分条件所在列。可以根据实际情况修改列标Dim tmpXtmpX = Application.InputBox("请输入拆分条件所在列:", "指定拆分条件所在列", "E", Type:=2)If tmpX = False Then Exit SubSplitCol = tmpX'指定标题行数，该区域不参与拆分tmpX = Application.InputBox("指定标题行数，该区域不参与拆分", "标题行数", "1", Type:=1)If tmpX = False Then Exit SubHeadRows = tmpX'-----------------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 NextFor i = 1 To lastrow - HeadRows '遍历arr所有数据 '提取其中的不重复值 If Len(arr(i, 1)) > 0 Then only.Add CStr(arr(i, 1)), CStr(arr(i, 1))Next iShtIndex = ActiveSheet.Index '获取当前表位置'-----------------Dim ikeysikeys = only.keys'-----------------On Error Resume NextFor i = 0 To only.Count - 1 Debug.Print Sheets(ikeys(i)).Name '获取与only对象中每个元素同名的工作表名（用意为判断是否存在该工作表） If Err = 0 Then MsgBox "当前工作簿已存在与待拆分项目同名的工作表""" & ikeys(i) & """，暂无法拆分", 64, "友情提示": Exit Sub Err.ClearNext i'-----------------Application.ScreenUpdating = False '关闭屏幕更新，加快执行速度Application.Calculation = xlCalculationManual '调为手动计算，加快执行速度For i = 0 To only.Count - 1 '创建工作表，表的数量与表名由only对象中不重复值而定 Sheets.Add After:=Sheets(Sheets.Count) '创建 Sheets(Sheets.Count).Name = ikeys(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 IfNext i '第一列为空时，会有bug'-----------------Application.ScreenUpdating = True '恢复屏幕更新Application.Calculation = xlCalculationAutomatic '恢复自动计算MsgBox "拆分完毕！", 64, "友情提示"End Sub
