【VBA】VBA编写的，将一列中相同的内容的行提取出来单独生成文件

Private Sub Command_OLIVER()
Dim arr
arr = Range("A1:C" & [a65536].End(3).Row)

Dim i As Long, wName As String, wPath As String
wName = "分类汇总" & Format(Now(), "hhmmss")
Dim dc As Object, wb As Workbook, n As Long
Set dc = CreateObject("Scripting.dictionary")

wPath = ThisWorkbook.Path & "\" & wName
MkDir wPath
For i = 2 To UBound(arr)
If Not dc.exists(arr(i, 1)) Then
Set wb = Workbooks.Add
wb.SaveAs wPath & "\" & arr(i, 1) & ".xls"   '001
wb.Sheets(1).Name = arr(i, 1)
'填写表头
wb.Sheets(1).[a1] = arr(1, 1)
wb.Sheets(1).[b1] = arr(1, 2)
wb.Sheets(1).[c1] = arr(1, 3)
dc.Add arr(i, 1), ""
End If
With Workbooks(arr(i, 1) & ".xls").Sheets(1)   '002
n = .[a65536].End(3).Row + 1
.Cells(n, 1) = arr(i, 1)
.Cells(n, 2) = arr(i, 2)
.Cells(n, 3) = arr(i, 3)
End With
Next

Dim ar
ar = dc.keys
For i = 0 To UBound(ar)
Workbooks(ar(i) & ".xls").Close True   '003
Next
End Sub

Sub 调用()
Command_OLIVER
End Sub