拆分表格 不同工作簿

Sub chaifen()
Dim r, Arr, d, k, i
Dim rng As Range
Dim sht As Worksheet, Sht1 As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Sht1 = ActiveSheet  'sht1为当前活动工作表
For Each sht In Sheets
If sht.Name <> Sht1.Name Then sht.Delete   '运行程序之前先将多余的工作表删除
Next
On Error Resume Next
r = [a65536].End(xlUp).Row
Arr = Range("a1:q" & r)
For i = 1 To UBound(Arr)
d(Arr(i, 2)) = i
Next
k = d.keys            '订单编号放入数组k
Set rng = Range("a1:q" & r)   '要拆分的区域
i = i + 1
For i = 1 To UBound(k)    '下面按不重复的订单号进行自动筛选
rng.AutoFilter 2, Criteria1:=k(i)     '自动筛选，2表示基准字段是第2列，Criterial是关键字
rng.Copy                  '筛选结果进行复制
Sheets.Add after:=Sheets(Sheets.Count)     '添加一个工作表，放了所以表之后
ActiveSheet.Name = k(i)     '给新加的工作表命名
ActiveSheet.Paste           '把上面复制的内容粘贴
Columns("a:h").AutoFit      '调整单元格宽度为自适应
[a2].Select
Next
rng.AutoFilter          '取消自动筛选
Sht1.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub