如何将筛选内容自动另存为工作簿

第1块, 产生分表

1. Sub TT()

2. Dim Cel As Range, Res

3. Dim i, a As Integer

4. Set d = CreateObject("Scripting.Dictionary")

5. For Each Cel In Range("C2:C" & ThisWorkbook.Worksheets("sheet1").Range("c65536").End(xlUp).Row)

6. If Cel <> "" Then

7. If Not d.exists(Cel.Value) Then d.Add Cel.Value, Cel.Value

8. End If

9. Next

10. Res = d.Items

11. For i = 0 To d.Count - 1

12. Sheets.Add After:=Sheets(Sheets.Count)

13. ActiveSheet.Name = Res(i)

14. ActiveSheet.Cells(1, 1) = Worksheets("sheet1").Cells(1, 1)

15. ActiveSheet.Cells(1, 2) = Worksheets("sheet1").Cells(1, 2)

16. ActiveSheet.Cells(1, 3) = Worksheets("sheet1").Cells(1, 3)

17. a = 2

18. With Worksheets(1).Range("C1:C" & Worksheets(1).Range("c65536").End(xlUp).Row)

19. Set c = .Find(Res(i), LookIn:=xlValues)

20. If Not c Is Nothing Then

21. firstAddress = c.Address

22. Do

23. ActiveSheet.Cells(a, 1) = Worksheets(1).Cells(c.Row, 1).Value

24. ActiveSheet.Cells(a, 2) = "'" & Worksheets(1).Cells(c.Row, 2).Value

25. ActiveSheet.Cells(a, 3) = Res(i)

26. a = a + 1

27. Set c = .FindNext(c)

28. Loop While Not c Is Nothing And c.Address <> firstAddress

29. End If

30. End With

31. Next i

32. Worksheets(1).Select

33. End Sub

复制代码

第2块,产生单独的文件.

1. Sub AA()

2. Dim i As Integer, nn As String

3. If Sheets.Count = 1 Then

4. MsgBox "You haven't generated seperated sheets."

5. Exit Sub

6. Else

7. For i = 2 To Sheets.Count

8. nn = Sheets(i).Name

9. Sheets(i).Select

10. Sheets(i).Copy

11. ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & nn & ".xls", _

12. FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

13. ActiveWindow.Close

14. Next i

15. End If

16. Worksheets(1).Select

17. End Sub

复制代码