请按班别拆分为工作簿
Sub 筛选拆分()
Dim d As Object, sht As Worksheet, arr,brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&,tCol&, aCol&, pd&, Cll As Range
Dim wb As Object, mysht As Worksheet
Set d =CreateObject("scripting.dictionary") 'set字典
' Set Rg = Application.InputBox("请框选拆分依据列!只能选择单列单元格区域!", Title:="提示", Type:=8)
' '用户选择的拆分依据列
' tCol = Rg.Column '取拆分依据列列标
' tRow = Val(Application.InputBox("请输入总表标题行的行数?"))
' '用户设置总表的标题行数
' If tRow < 0 Then MsgBox "标题行数不能为负数,程序退出。":Exit Sub
tCol = 3
tRow = 3
Range("A1").AutoFilterField:=1 '不论当前是否是筛选状态,保证A1所在区域成为筛选状态
Range("A1").AutoFilter
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.Calculation = xlManual
ActiveWB = ActiveWorkbook.Name
Set mysht = ActiveSheet
LastRow = Cells.Find("*", , , ,1, 2).Row
LastCol = Cells.Find("*", , , , 2,2).Column
Set Rng = Range(Cells(tRow, 1),Cells(LastRow, LastCol))
For i = tRow + 1 To LastRow
s= Cells(i, tCol)
If s <> "" Then
d(s) = ""
End If
Next i
arr = d.keys
m = 0
For Each r In arr
'' Set wb = Workbooks.Add
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = "数据"
Rng.AutoFilter Field:=tCol, Criteria1:=r
mysht.Activate
Range(Cells(1, 1), Cells(LastRow, LastCol)).Copysht.Range("A1")
sht.Move
ActiveWorkbook.SaveAsFilename:=ThisWorkbook.Path & "\" & r & ".xlsx"
ActiveWorkbook.Close True
Workbooks(ActiveWB).Activate '激活待拆分的工作簿
m= m + 1
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.Calculation = xlAutomatic
Range("A1").AutoFilterField:=1 '不论当前是否是筛选状态,保证A1所在区域成为筛选状态
Range("A1").AutoFilter
End Sub
完成,代码先放在,等有时间再整理,搞一个通用性的代码