EXCEL表如何将一个总表按某列分类汇总后，然后自动生成其分类后的若干新表。 自动生成下图效果

自己收藏的一个：在代码窗口新建一个模块，粘贴此代码。然后运行。

Sub 自动分表()

删除分表

Dim E As Integer

Dim RanB As Range

Dim RanA As Range

Dim Y As Integer

Dim X As String

Dim ARR() As String

Dim P As Integer

Dim ICol

ICol = Application.InputBox("请输入你所要分的列1-11列：" & Chr(10) & "（如按B列分请输入2）", "提示：", "4", Type:=1)

If ICol = "" Then Exit Sub

Application.ScreenUpdating = False

For Each RanB In Sheet1.Range(Cells(2, ICol), Cells(Sheet1.Range("d65536").End(xlUp).Row, ICol))

If RanB <> "" Then

If InStr(X, Sheet1.Cells(RanB.Row, ICol)) = 0 Then

If X = "" Then

X = RanB

Else

X = X & "," & RanB

End If

E = Application.CountIf(Sheet1.Columns(ICol), RanB)

ReDim ARR(1 To E + 1, 1 To 11)

Set RanA = Sheet1.Cells(1, ICol)

For Y = 1 To E

Set RanA = Sheet1.Columns(ICol).Find(RanB, RanA, , , xlByColumns, , , False)

For P = 1 To 11

If Y = 1 Then

ARR(Y, P) = Sheet1.Cells(1, P)

ARR(Y + 1, P) = Sheet1.Cells(RanA.Row, P)

Else

ARR(Y + 1, P) = Sheet1.Cells(RanA.Row, P)

End If

Next P

Next Y

'上面部为：按条件生成多个分表，用数组方式，查找方式，循环

'*********************************************************************

'这一部分为加网线

Sheets.Add.Name = RanB '新建工作表，重命名

With ActiveSheet

.Range("A3").Resize(Y, 11) = ARR '粘贴数据

.Rows("2:2").RowHeight = 6 '2行缩少高度

.Range("A3:K" & E + 3).Borders.LineStyle = 1 '全部加网格线

.Range("A1") = Sheet1.Cells(1, ICol) & RanB & "号成绩表" '表头名

.Range("A1:K1").Select '全选A1:K1

With Selection

.MergeCells = True '合并A1:K1

.HorizontalAlignment = xlCenter '居中A1:K1

.Font.Size = 22 '字体设为22号

End With

End With

Sheet1.Select

End If

End If

Next

Sheets("总表").Select

Application.ScreenUpdating = True

MsgBox "已经按 " & Sheet1.Cells(1, ICol) & " 生成分表:" & Chr(10) & X, 48, "提示"

Exit Sub

100:

MsgBox "运行出错", 48, "出错"

End Sub

Sub 删除