|
- Sub Macro1()
- Dim arr, d, sht As Worksheet, i&
- Set d = CreateObject("scripting.dictionary")
- Set sht = ThisWorkbook.Sheets(1)
- arr = Range("a1").CurrentRegion
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Application.SheetsInNewWorkbook = 1
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 4)) Then
- d(arr(i, 4)) = ""
- sht.[d1].AutoFilter Field:=4, Criteria1:=arr(i, 4)
- With Workbooks.Add
- sht.[a:f].Copy .Sheets(1).[a1]
- .SaveAs Filename:=ThisWorkbook.Path & "" & arr(i, 4) & ".xls"
- .Close 1
- End With
- ActiveSheet.ShowAllData
- End If
- Next
- Application.SheetsInNewWorkbook = 3
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|