如下图是某年级两个班级成绩表，现在我们想要按照班级的不同将此工作表拆分为两个。

全选表格区域，然后同时按下Alt+F11

点击sheet1选项，然后在右边空白区域录入vba代码

点击【运行】，选择【运行宏】或者直接按下F5运行vba程序

在弹出对话框内输入A，然后点击【确定】

录入标题行数1，然后点击【确定】就可以完成了

完成效果如下图，最后跟大家分享一下本文这里使用的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

如有疑问可以点击下方【我有疑问】，与我沟通交流！！