Excel 每张表保存为独立的工作簿

'按班新建表Function NewTableByColumn()    On Error Resume Next    Dim tableName As String, colIndex As String '分类所在列    Dim startRowNumber  As Integer  '开始行    startRowNumber = 2: colIndex = "G"    Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets(1)    Dim rng As Range, Rang As Range '班级区域    Set Rang = Null: Set rng = Null    For r = startRowNumber To sh.UsedRange.Rows.Count        tableName = sh.Cells(r, colIndex) '        If sh.Cells(r, colIndex) = sh.Cells(r - 1, colIndex) Then '属于同一个班级            Set rng = sh.Cells(r, colIndex).EntireRow            Set Rang = Union(Rang, rng)        Else '下一个班级  新建班级 新建班级之前将上一个班级全部数据复制到对应的班级表中            With Rang                .Copy Destination:=ThisWorkbook.Worksheets(Worksheets.Count).[a2].Resize(.Rows.Count, .Columns.Count)            End With            If Not IsTableExist(tableName) Then                addTable (tableName)            End If            Set Rang = Null: Set Rang = sh.Cells(r, colIndex).EntireRow        End If    Next r    With Rang    '最后一个班级复制        .Copy Destination:=ThisWorkbook.Worksheets(Worksheets.Count).[a2].Resize(.Rows.Count, .Columns.Count)    End WithEnd FunctionFunction addTable(tableName As String)    Dim sh As Worksheet    Set sh = ThisWorkbook.Sheets(1)    Worksheets.Add after:=Worksheets(Worksheets.Count)    Dim sht As Worksheet    Set sht = ThisWorkbook.Sheets.Item(Worksheets.Count)    With sht        .Name = tableName        sh.Rows(1).Copy Destination:=.[a1].Resize(1, sh.UsedRange.Columns.Count)    End WithEnd FunctionFunction IsTableExist(tableName As String) As Boolean    On Error Resume Next    If Sheets(tableName) Is Nothing Then        IsTableExist = False    Else        IsTableExist = True    End IfEnd FunctionSub 另存所有工作表为单独的工作簿()    Dim sht As Worksheet, myPath    Application.ScreenUpdating = False    myPath = ThisWorkbook.Path & "\"    For Each sht In ThisWorkbook.Sheets        sht.Copy'        Kill myPatht & sht.Name & ".xls"        ActiveWorkbook.SaveAs myPath & sht.Name & "_无合格银行卡号学生名单" & ".xls"        ActiveWorkbook.Close    Next    Application.ScreenUpdating = TrueEnd Sub