'按班新建表
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
Excel 每张表保存为独立的工作簿
最新推荐文章于 2022-09-17 12:33:27 发布