owen06

¦^´_ 1# tomtracy


    §Afor ah = 1 To NameCount¤§«á¤U­±ªºnext ¤£À³¸Ó¬Oaj¡AµM«áwith§¹²¦¤§«á¤U­±¨S¦³±µend with

owen06

¦^´_ 4# tomtracy

¤j¤j³o¼Ë°õ¦æµ²ªG¥¿½T¶Ü¡H

1. Sub Macr4()
   
2. 
   
3. On Error Resume Next
   
4. 
   
5. Dim mySheetName As String
   
6. mySheetName = ActiveWorkbook.ActiveSheet.Name
   
7. 
   
8. For Each sht In ActiveWorkbook.Sheets
   
9. Application.DisplayAlerts = False
   
10. 'Ãö³¬Äµ§iµøµ¡
    
11. If sht.Name <> mySheetName Then sht.Delete
    
12. 
    
13. Application.DisplayAlerts = True
    
14. '«ì´_ĵ§iµøµ¡
    
15. Next sht
    
16. 
    
17. 
    
18. With Sheets(mySheetName)
    
19. .Columns("s:ah").ClearContents
    
20. .Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("R1"), Unique:=True
    
21. End With
    
22. 
    
23. Dim NameCount As Integer
    
24. NameCount = Sheets(mySheetName).Range("R1").End(xlDown).Row - 1
    
25. For ah = 1 To NameCount
    
26. ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
    
27. ActiveSheet.Name = Sheets(mySheetName).Cells(ah + 1, 18)
    
28. Next
    
29. 
    
30. 
    
31. Dim myName As String
    
32. Sheets(mySheetName).Select
    
33. For aj = 1 To NameCount
    
34. myName = Range("R2")
    
35. MsgBox myName
    
36. Columns("s:ah").ClearContents
    
37. Columns("A:P").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
    
38. "R1:R2"), CopyToRange:=Range("s1"), Unique:=False
    
39. Columns("s:ah").Copy Sheets(myName).Range("A1")
    
40. Range("R2").Delete Shift:=xlUp
    
41. Next aj
    
42. Sheets(mySheetName).Columns("s:ah").ClearContents
    
43. End Sub

½Æ»s¥N½X