多sheet拆分问题，求答疑！

代码在这里
Sub chai()
Dim rng As Range, sth As Worksheet, BookN As Workbook, pathn$, zd As Object, arr, crng As Range
Set zd = CreateObject("scripting.dictionary")
pathn = ActiveWorkbook.Path
Set sth = ActiveSheet
Set rng = Application.InputBox("请选择表头区域", "表头区域的确定", , , , , , 8)
TitleR = rng.Rows.Count
TitleC = rng.Column
TitleColNum = rng.Columns.Count
Set crng = Application.InputBox("请选择拆分列标准列", "标准列的确定", , , , , , 8)
num = crng.Column - TitleC + 1
l = ActiveSheet.Cells(Rows.Count, TitleR).End(xlUp).Row
arr = Range(Cells(TitleR + 1, TitleC), Cells(l, TitleColNum + TitleC - 1))
For Each sth In Worksheets
For i = 1 To UBound(arr)
If Not zd.exists(arr(i, num)) Then
Set zd(arr(i, num)) = CreateObject("scripting.dictionary")
End If
If Not zd(arr(i, num)).exists(sth.Name) Then
Set zd(arr(i, num))(sth.Name) = sth.Cells(i + TitleR, TitleC).Resize(1, TitleColNum)
Else
Set zd(arr(i, num))(sth.Name) = Union(zd(arr(i, num))(sth.Name), sth.Cells(i + TitleR, TitleC).Resize(1, TitleColNum))
End If
Next i
Next sth
For Each Item In zd.keys
Application.SheetsInNewWorkbook = zd(Item).Count
Set BookN = Workbooks.Add
k = 0
With BookN
For Each items In zd(Item).keys
k = k + 1
With .Worksheets(k)
.Name = items
rng.Copy .Cells(1, 1)
zd(Item)(items).Copy .Cells(TitleR + 1, 1)
End With
Next
End With
ActiveWorkbook.SaveAs pathn & "\" & Item
ActiveWorkbook.Close False
Next Item
End Sub