登陆

WPS Excel全年级成绩按班级拆分成单独表格的方法

WBB2023-11-1637人围观 ,发现0个评论

很多人在问,怎么按班级拆分表格,建立新的表格。今天他来了。网上的什么宏代码啥的,很难用。折腾了半天,发现wps自带这个功能。表格拆分方法如下:

第一种方法(视频在最后):

前提:有wps会员。平时做活动都白菜价了,别说你开不起。

第1步:打开wps表格,点击智能工具箱

WPS Excel全年级成绩按班级拆分成单独表格的方法

第2步:点击拆分表格,选择按内容拆分

WPS Excel全年级成绩按班级拆分成单独表格的方法

第3步:点击拆分工具右边的图标,用鼠标点击A列拖到R,选择拆分内容

WPS Excel全年级成绩按班级拆分成单独表格的方法

第4步:选择生成不同的新文件(如果选择新工作表会在同一文件下方生成新表),选择保存路径,选择拆分依据。

WPS Excel全年级成绩按班级拆分成单独表格的方法

第5步:点击开始拆分,拆分完毕后点击打开文件夹,完毕。

WPS Excel全年级成绩按班级拆分成单独表格的方法

WPS Excel全年级成绩按班级拆分成单独表格的方法

第二种方法

利用宏插件

使用方法:

1、开发工具-vb宏(提前装宏插件)-输入代码-运行-输入列分类另存。完毕。

WPS Excel全年级成绩按班级拆分成单独表格的方法

2、插入-窗体-按钮,输入列分类另存。完毕。

WPS Excel全年级成绩按班级拆分成单独表格的方法

这种方法如果要另存为单个文件依旧需要用工具箱,比较鸡肋。

-------------------------------------------------------------------

代码如下

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

----------------------------------------------------------------

代码附件下载:

excel批量筛选另存为各表-升级7.zip

----------------------------------------------------------------

操作视频:


请发表您的评论
不容错过
Powered By Z-BlogPHP