很多人在问，怎么按班级拆分表格，建立新的表格。今天他来了。网上的什么宏代码啥的，很难用。折腾了半天，发现wps自带这个功能。表格拆分方法如下：
第一种方法（视频在最后）：
前提：有wps会员。平时做活动都白菜价了，别说你开不起。
第1步：打开wps表格，点击智能工具箱
第2步：点击拆分表格，选择按内容拆分
第3步：点击拆分工具右边的图标，用鼠标点击A列拖到R，选择拆分内容
第4步：选择生成不同的新文件（如果选择新工作表会在同一文件下方生成新表），选择保存路径，选择拆分依据。
第5步：点击开始拆分，拆分完毕后点击打开文件夹，完毕。
第二种方法
利用宏插件
使用方法：
1、开发工具-vb宏（提前装宏插件）-输入代码-运行-输入列分类另存。完毕。
2、插入-窗体-按钮，输入列分类另存。完毕。
这种方法如果要另存为单个文件依旧需要用工具箱，比较鸡肋。
-------------------------------------------------------------------
代码如下
Sub 批量筛选另存表()
Dim shtData As Worksheet
Dim maxRow, maxCol, startColCopy, startRowFilter As Long
Dim tmpMaxRow, numFilterCol, startRowCopy As Long
Dim tmpShtName, tmpStr, strNumCol As String
Dim strSpecialChar As String
Dim arrSpecialChar
Set shtData = ActiveSheet '当前数据表名
startRowFilter = 1 '筛选开始行，包括表标题行
startRowCopy = 1 '复制开始行，要小于等于筛选开始行startRowFilter，一般也不用改
startColCopy = 1 '复制开始列，要小于等于筛选输入的列，一般也不用改
strSpecialChar = "|、\、/、*、?、<、>、" '命名的特殊字符。
strSpecialChar = strSpecialChar & """"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
If startRowFilter < startRowCopy Then
MsgBox "复制开始行要小于等于筛选开始行，请重新调整设置！", vbExclamation
Exit Sub
End If
inputFlag:
strNumCol = InputBox("输入要筛选的列（为数字。如筛选B列，就输入2，其他类推）？") '筛选列号
If Len(strNumCol) = 0 Then
Exit Sub
End If
If IsNumeric(strNumCol) = False Then
MsgBox "请输入正确的列号！", vbExclamation
GoTo inputFlag
End If
numFilterCol = strNumCol * 1
If numFilterCol <= 0 Then
MsgBox "输入的数字应大于0！", vbExclamation
GoTo inputFlag
End If
If Int(numFilterCol) <> numFilterCol Then
MsgBox "请输入整数！", vbExclamation
GoTo inputFlag
End If
If MsgBox("你确定要全部另存为表么？", vbYesNo + vbExclamation, "导出表") = vbNo Then
Exit Sub
End If
Cells.AutoFilter
arrSpecialChar = Split(strSpecialChar, "、")
maxRow = shtData.Cells(Rows.Count, numFilterCol).End(xlUp).Row
maxCol = shtData.Cells(startRowFilter, Columns.Count).End(xlToLeft).Column
Set dicFilter = CreateObject("Scripting.Dictionary")
For i = startRowFilter + 1 To maxRow
tmpStr = shtData.Cells(i, numFilterCol).Value
If Len(tmpStr) <= 0 Then
GoTo nextFor
End If
tmpStr = CStr(tmpStr)
If dicFilter.exists(tmpStr) Then
GoTo nextFor
End If
For m = 0 To UBound(arrSpecialChar)
If InStr(tmpStr, arrSpecialChar(m)) > 0 Then
MsgBox "该筛选【" & tmpStr & "】包含了特殊字符【" & arrSpecialChar(m) & "】，无法完成该筛选的，请修改后再试！", vbExclamation
GoTo nextFor
End If
Next
dicFilter(tmpStr) = tmpStr
tmpShtName = tmpStr
For Each shTmp In Sheets
If LCase(shTmp.Name) = LCase(tmpShtName) Then
shTmp.Delete
Exit For
End If
Next
shtData.Select
Range(Cells(startRowFilter, startColCopy), Cells(maxRow, maxCol)).AutoFilter Field:=numFilterCol, Criteria1:=tmpStr
tmpMaxRow = shtData.Cells(Rows.Count, numFilterCol).End(xlUp).Row
If tmpMaxRow <= startRowFilter Then GoTo nextFor
Sheets.Add(After:=Sheets(Sheets.Count)).Name = tmpShtName
'列宽
For j = startColCopy To maxCol
Sheets(tmpShtName).Columns(j - startColCopy + 1).ColumnWidth = shtData.Columns(j).ColumnWidth
Next
'值
shtData.Select
Range(Cells(startRowCopy, startColCopy), Cells(tmpMaxRow, maxCol)).Select
Selection.Copy
Sheets(tmpShtName).Select
Range("A1").Select
ActiveSheet.Paste
Range(Cells(startRowFilter - startRowCopy + 1, startColCopy), Cells(maxRow, maxCol)).AutoFilter
Range("A1").Select
shtData.Select
nextFor:
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
shtData.Select
shtData.Range(Cells(startRowFilter, startColCopy), Cells(maxRow, maxCol)).AutoFilter Field:=numFilterCol
Range("A1").Select
MsgBox "导出完成！", vbExclamation
End Sub
'删除生成的工作表
Sub 删除表()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If MsgBox("你确定要删除全部生成的表么？", vbYesNo + vbExclamation, "系统提示") = vbNo Then
Exit Sub
End If
Set shtData = ActiveSheet '当前数据表名
For Each shtTmp In Sheets
If shtTmp.Name <> shtData.Name Then
shtTmp.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "删除成功！", vbExclamation
End Sub
----------------------------------------------------------------
代码附件下载：
----------------------------------------------------------------
操作视频：
