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 With
End Function
Function 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 With
End Function
Function IsTableExist(tableName As String) As Boolean
    On Error Resume Next
    If Sheets(tableName) Is Nothing Then
        IsTableExist = False
    Else
        IsTableExist = True
    End If
End Function



Sub 另存所有工作表为单独的工作簿()
    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 = True
End Sub