总名单拆分

雪域夜鹰

大家帮帮忙

活在理想的世界

Sub D()
Dim Dic, Fso, WB As Workbook, arr(), sht As Worksheet, tb As Workbook, sht1 As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set tb = ThisWorkbook
On Error Resume Next
Fso.GetFolder(ThisWorkbook.Path & "\想要的结果\").Delete
Fso.CreateFolder (ThisWorkbook.Path & "\想要的结果\")
Set sht1 = tb.Worksheets(1)
arr = sht1.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
    Dic(arr(i, 20)) = ""
Next
For Each ii In Dic.Keys
    Set WB = Workbooks.Add
    Set sht = WB.Sheets(1)
    sht1.Range("a1").CurrentRegion.AutoFilter 20, ii
    sht1.Range("a1").CurrentRegion.Copy sht.Range("a1")
    WB.SaveAs ThisWorkbook.Path & "\想要的结果\" & ii & ".xlsx"
    WB.Close
Next
sht1.Range("a1").CurrentRegion.AutoFilter
End Sub

蓝桥玄霜

http://club.excelhome.net/thread-1040679-1-1.html

雪域夜鹰

谢谢老师的帮助