[µo°Ý] ½Ð°Ý¦p¦ó¨Ì¿z¿ïÄ檺Ãþ§O,¦Û°Ê«Ø¥ß¤À­¶«Ø¥ß«á¨Ã¤ÀÃþ¸ê®Æ?

starry1314

¥Ø«e¶·¤â°Ê«Ø¥ß¿z¿ïÄæ¦ì¤ºªº¤À­¶¤~¯à¦Û°Ê¾É¤J¸ê®Æ

1. Sub Ex()
   
2.     Dim Sh As Worksheet
   
3.     With Sheets("·JÁ`©ú²Ó")
   
4.         For Each Sh In Sheets          'Sheets : ¤u§@ªíª«¥óªº¶°¦Xª«¥ó
   
5.             If Sh.Name <> .Name Then   '¤u§@ªíªº¦WºÙ<>"·JÁ`©ú²Ó"
   
6.                 .Range("A1").AutoFilter Field:=2, Criteria1:=Sh.Name
   
7.                 '"·JÁ`©ú²Ó" ¦Û°Ê¿z¿ï  ¿z¿ï°ò·ÇÄæ¦ì:=²Ä2Äæ , ¿z¿ï·Ç«h:="¤u§@ªí¦WºÙ"
   
8.                 .UsedRange.Columns("a:d").Copy Sh.[a1] '"·JÁ`©ú²Ó" ¦Û°Ê¿z¿ï«áªº¸ê®Æ, ½Æ»s
   
9.             End If
   
10.         Next
    
11.         .Range("A1").AutoFilter   '¨ú®ø "·JÁ`©ú²Ó"¦Û°Ê¿z¿ï¼Ò¦¡
    
12.     End With
    
13. End Sub

½Æ»s¥N½X

starry1314

¦^´_ 4# GBKEE

·PÁª©¤j~§V¤O§l¦¬¡I¡I¡I

GBKEE

¶i¶¥¿z¿ï+¦Û°Ê¿z¿ï

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, Ar As Variant, i As Integer, M As Variant
   
4.     With ActiveWorkbook.Sheets("·JÁ`©ú²Ó")
   
5.         .Range("b:b").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
   
6.         With .Cells(1, .Columns.Count).EntireColumn
   
7.             Ar = .SpecialCells(xlCellTypeConstants)
   
8.             Ar = Application.WorksheetFunction.Transpose(Ar)
   
9.             .Cells = ""
   
10.         End With
    
11.         On Error GoTo Sheet_Add   '³B¸Ì¤u§@ªí¤£¦s¦bªº¿ù»~
    
12.         For i = 2 To UBound(Ar)
    
13.             .Range("A1").AutoFilter Field:=2, Criteria1:=Ar(i)
    
14.             .UsedRange.Columns("a:d").Copy ActiveWorkbook.Sheets(Ar(i)).[a1] '"·JÁ`©ú²Ó" ¦Û°Ê¿z¿ï«áªº¸ê®Æ, ½Æ»s
    
15.         Next
    
16.         .Range("A1").AutoFilter   '¨ú®ø "·JÁ`©ú²Ó"¦Û°Ê¿z¿ï¼Ò¦¡
    
17.         .Activate
    
18.         On Error GoTo 0             'µ{¦¡¦³¿ù»~¤£³B¸Ì
    
19.         '§R°£¤u§@ªí¤£¦s"·JÁ`©ú²Ó"¿z¿ïÄ檺Ãþ§O
    
20.         Application.DisplayAlerts = False
    
21.         For Each Sh In ActiveWorkbook.Sheets
    
22.             If Sh.Name <> .Name Then If IsError(Application.Match(Sh.Name, Ar, 0)) Then Sh.Delete
    
23.         Next
    
24.         Application.DisplayAlerts = True
    
25.     End With
    
26.     Exit Sub
    
27. '******************************
    
28. Sheet_Add:
    
29.      ActiveWorkbook.Sheets.Add.Name = Ar(i)
    
30.     Resume
    
31. End Sub

½Æ»s¥N½X

starry1314

¦^´_ 2# ­ã´£³¡ªL

¤Ó·PÁ§A¤F¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I¡I

­ã´£³¡ªL

Sub test()
Dim Sht As Worksheet, xD, xR As Range
Set xD = CreateObject("Scripting.Dictionary")
xD("") = 1
With Sheets("·JÁ`©ú²Ó").UsedRange
¡@¡@For Each xR In .Columns(2).Offset(1, 0).Cells
¡@¡@¡@¡@If xD(xR.Value) = "" Then
¡@¡@¡@¡@¡@On Error Resume Next
¡@¡@¡@¡@¡@Set Sht = Sheets(xR.Value)
¡@¡@¡@¡@¡@On Error GoTo 0
¡@¡@¡@¡@¡@If Sht Is Nothing Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = xR.Value
¡@¡@¡@¡@¡@.AutoFilter Field:=2, Criteria1:=xR.Value
¡@¡@¡@¡@¡@.Columns("a:d").Copy Sheets(xR.Value).[a1]
¡@¡@¡@¡@¡@xD(xR.Value) = 1: Set Sht = Nothing
¡@¡@¡@¡@End If
¡@¡@Next
¡@¡@Application.Goto .Item(1)
End With
Sheets("·JÁ`©ú²Ó").AutoFilterMode = False
End Sub
¡@