Excel VBA原格式拆分工作表内容到多个工作簿

1. Sub 拆分abc123()
2.   Dim arr
3.   Dim wb As Workbook
4.   Application.ScreenUpdating = False
5.   Application.DisplayAlerts = False
6.   Set d = CreateObject("scripting.dictionary")
7.   With Worksheets("汇总表")
8.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
9.     arr = .Range("a1:f" & r)
10.     For i = 2 To UBound(arr)
11.       If Not d.exists(arr(i, 2)) Then
12.         Set d(arr(i, 2)) = Union(.Cells(1, 1).Resize(1, 6), .Cells(i, 1).Resize(1, 6))
13.       Else
14.         Set d(arr(i, 2)) = Union(d(arr(i, 2)), .Cells(i, 1).Resize(1, 6))
15.       End If
16.     Next
17.   End With
18. For Each aa In d.keys
19.     Set wb = Workbooks.Add
20.        With wb
21.           With .Worksheets(1)
22.              d(aa).Copy .Range("a1")
23.             .Name = aa
24.           End With
25.         .SaveAs ThisWorkbook.Path & "\拆分表" & aa
26.         .Close False
27.     End With
28.   Next
29.   Application.ScreenUpdating = True
30.   MsgBox "数据拆分完毕！"
31. End Sub

    代码仅供参考  如果数据有10万左右  运行时间大约5—6分钟 ********************** 1、点击按钮，将汇总表数据拆分到拆分表目录下面的3个工作簿的表中（3个工作簿及里面的表格已经存在，如有内容要清空） 2、要保证复制后的格式不变 3、数据量在10万左右，要保证性能