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&
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
Call disAppSet(False)
'建立备份文件夹
savePath = ThisWorkbook.Path & "\拆分" & Format(Now, "yyyymmdd_hhmm")
If Dir(savePath, vbDirectory) = "" Then
    MkDir savePath
End If
If Right(savePath, 1) <> "\" Then savePath = savePath & "\"
'不论当前是否是筛选状态，保证A1所在区域成为筛选状态
If ActiveSheet.FilterMode = True Then ActiveSheet.Cells.AutoFilter
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))
    Rng.AutoFilter Field:=tCol, Criteria1:=r
    mysht.Activate
    Range(Cells(1, 1), Cells(LastRow, LastCol)).Copy sht.Range("A1")
    sht.Move
    ActiveWorkbook.SaveAs Filename:=savePath & r
    ActiveWorkbook.Worksheets(1).Name = "数据"
    ActiveWorkbook.Close True
    Workbooks(ActiveWB).Activate                           '激活待拆分的工作簿
    m = m + 1
Next
If ActiveSheet.FilterMode = True Then ActiveSheet.Cells.AutoFilter
Call disAppSet(True)
MsgBox "完成! 拆分文件数:  " & m
End Sub
Sub disAppSet(flag As Boolean)
With Application
    .ScreenUpdating = flag
    .DisplayAlerts = flag
    .AskToUpdateLinks = flag
    If flag Then
        .Calculation = xlCalculationAutomatic
    Else
        .Calculation = xlCalculationManual
    End If
End With
End Sub