ExcelVBA请按班别拆分为工作簿(筛选复制法)

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