c_c_lai

¦^´_ 10# ¾Ç¨ì¦Ñ¦º
¦^´_ 9# yen956
¬°°t¦X¹ê°È¤Wªº¹ê»ÚÀ³¥Î¡A±N¥¦¾ã²z¤F¤@¤U¡A
¨Ã¤Þ¥Î¤@¨Ç¥i¯à¦]¯À¡A¥H¤Î¨B§½¦Ò¶q¡B¦Ó°µ
¥Xªº½d¨Ò¡A´£¨Ñ°Ñ¦Ò¬Ý¬Ý¡I

1. '  ½Ð¶K¨ì "·JÁ`ªí"
   
2. Sub ·J¤JÁ`ªí()
   
3.     Dim sh1 As Worksheet, sh2 As Worksheet
   
4.     Dim Lst1 As Integer
   
5.     Dim J As Integer
   
6.     Dim msg As Boolean
   
7.    
   
8.     Set sh1 = Sheets("·JÁ`ªí")
   
9.     sh1.Cells.Clear
   
10.     msg = False
    
11.    
    
12.     For J = 1 To Sheets.Count
    
13.         If Sheets(J).Name <> "·JÁ`ªí" Then
    
14.             Set sh2 = Sheets(J)
    
15.             Lst1 = IIf(sh1.[B65536].End(xlUp).Row = 1, 1, sh1.[B65536].End(xlUp).Row + 1)
    
16.            '  sh2.UsedRange.Address = "$B$4:$E$7" : String
    
17.            '  sh2.UsedRange.Offset(1, 0).Address = "$B$5:$E$8" : String
    
18.            '  ²Ä¤@¦¸»Ý¥ý³s¦P¼ÐÃD¤Î¨ä¤º®e¤@¨Ö·J¤J¨ìÁ`ªí¤º¡A¤§«á¶È½Æ»s¨C¤@¤u§@ªí³æ¤§¤º®e (¤£§t¼ÐÃD¦b¤º)¡C
    
19.            sh2.UsedRange.Offset(IIf(msg, 1, 0), 0).Copy sh1.Cells(Lst1, 2)
    
20.            msg = True
    
21.         End If
    
22.     Next
    
23. End Sub
    
24. 
    
25. '  ·J¥X¨ì¤À­¶
    
26. '  À³¥Î½d³ò¡G «Ø¥ß¦r¨å¡B¤j¤p±Æ§Ç¡B¶K»s½Æ»s¤º®e¡B¦p¦óÀˬd¤u§@ªí³æ¤w§_¦s¦b¡B°ÊºA²£¥Í¤u§@ªí³æ¡B
    
27. '             ²M°£¼È¦s¤u§@°Ï¶ô¡B¥H¤Î¦r¨åªº¹ê°ÈÀ³¥Î»P§Þ¥©¡C
    
28. Sub ·J¥X¨ì¤À­¶()
    
29.     Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, dic As Object
    
30.     Dim Lst1 As Integer, v As Variant
    
31.     Dim J As Integer, I As Integer
    
32.    
    
33.     Set dic = CreateObject("scripting.dictionary")
    
34.     Set sh1 = Sheets("·JÁ`ªí")
    
35.     Lst1 = sh1.[B65536].End(xlUp).Row
    
36.    
    
37.     sh1.Range("B1:E" & Lst1).Copy sh1.[W1]     '  ¥tÅP¾Ô³õ (B Äæ¥ý«ö·Ó¦r¥À¤j¤p±Æ§Ç«á¦A¦æ·J¥X¨ì¦U¬ÛÃö¤u§@ªí³æ)
    
38.     With [W2].Resize(Lst1 - 1, 4)
    
39.         .Cells.Sort Key1:=.Cells(1), Key2:=.Cells(3), Order1:=xlAscending, Header:=xlNo    '  xlDescending
    
40.     End With
    
41.    
    
42.     For J = 2 To Lst1
    
43.         dic(sh1.Range("W" & J).Text) = dic(sh1.Range("W" & J).Text) + 1
    
44.     Next J
    
45.    
    
46.     Set rng = Sheets("·JÁ`ªí").[W2]
    
47.     For Each v In dic.KEYS            '   v = "A" : Variant/String
    
48.         I = dic.Item(v)               '   I = 3 : Integer
    
49.         J = checkShts(CStr(v))
    
50.         
    
51.         If J > 0 Then
    
52.             Set sh2 = Sheets(J)
    
53.         Else
    
54.             Set sh2 = Sheets.Add(After:=Sheets(Sheets.Count))
    
55.             sh2.Name = v
    
56.         End If
    
57.         
    
58.         With sh2
    
59.             .Cells.Clear
    
60.             sh1.[W1:Z1].Copy .[B1]
    
61.             rng.Resize(I, 4).Copy .[B2]
    
62.             Set rng = rng.Offset(I)       '  Rng.Address = "$B$5" : Rng.Address = "$B$7" : String
    
63.         End With                          '  Rng.Address = "$B$8" : String
    
64.     Next
    
65.     sh1.[W:Z].Clear                       '  ²M°£¥tÅP¤§¾Ô³õ (W ¦Ü Z Ä涡¤º®e)
    
66. End Sub
    
67. 
    
68. Function checkShts(vSht As String) As Integer
    
69.     Dim flg As Integer
    
70.    
    
71.     For flg = 1 To Sheets.Count
    
72.         If Sheets(flg).Name = vSht Then checkShts = flg: Exit Function
    
73.     Next flg
    
74.     checkShts = 0
    
75. End Function

½Æ»s¥N½X

yen956

'­É¥Î c¤j ªº·§©À, ·s¼W¤À­¶, ³o¼Ë¸û¦³¼u©Ê
'½Ð¶K¨ì "·JÁ`ªí"
'·J¥X¨ì¤À­¶3
'§P§P¤À­¶¬O§_¦s¦b
Function shExist(ByVal shName As String) As Boolean
    Dim I As Integer
    shExist = False
    For I = 1 To Sheets.Count
        If Sheets(I).Name = shName Then
            shExist = True
            Exit Function
        End If
    Next
End Function

Sub ·J¥X¨ì¤À­¶3()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shNameCnt As Integer
    Dim I As Integer, J As Integer
   
    '********************
    '²M°£¤À­¶¤º®e, ¦p¦³¨ä¥L­«­n¤À­¶, ¦p"²Î­p"µ¥, ¨â¦C*****¶¡, ½Ðµù¸Ñ±¼©Î§R±¼
    For J = 1 To Sheets.Count
        If Sheets(J).Name <> "·JÁ`ªí" Then Sheets(J).Cells.Clear
    Next
    '**************
   
    '¥[¤J­ì§Ç¸¹, ¤è«K«ì´_­ìª¬(¼È©ñÄæA,¥i§ï©ñ§OÄæ)
    Lst1 = [B65536].End(xlUp).Row
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '«ö¤u§@ªí¦WºÙ±Æ§Ç
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    For I = 5 To Lst1
        shName = Cells(I, 2)
        
        '§P§P¤À­¶¬O§_¦s¦b, ¦p¤£¦s¦b«h·s¼W¤@­¶
        If Not shExist(shName) Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        [C4:E4].Copy Sheets(shName).[C4]     '½Æ»s¼ÐÃD
        [C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])"   '­pºâ¦P¦Wªº¤u§@ªí¦³´X­Ó
        Cells(I, 2).Resize([C3], 4).Copy Sheets(shName).[B5]         '§å¦¸½Æ»s
        I = I + [C3] - 1
    Next
   
    '«ì´_­ìª¬, «ö­ì§Ç¸¹±Æ§Ç, ¨Ã²M°£¼È¦s°Ï
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear: [C3].Clear    'ÄæA ¤Î [C3] §¡¬°¼È¦s°Ï
End Sub

­ã´£³¡ªL

¿z¿ïªk¡I¡I¡I

Sub Macro1()
Dim xArea As Range, i&, T$, TT$, Sht As Worksheet
Set xArea = Range([B4], Cells(Rows.Count, "B").End(xlUp)(1, 4))
For i = 2 To xArea.Rows.Count
¡@¡@T = xArea(i, 1): Set Sht = Nothing
¡@¡@If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
¡@¡@On Error Resume Next:   Set Sht = Sheets(T):  On Error GoTo 0
¡@¡@If Sht Is Nothing Then Set Sht = Sheets.Add(After:=Sheets(Sheets.Count))
¡@¡@Sht.Name = T: Sht.UsedRange.Clear
¡@¡@With xArea
¡@¡@¡@¡@.Parent.Select
¡@¡@¡@¡@.AutoFilter Field:=1, Criteria1:=T
¡@¡@¡@¡@.Copy Sht.[B4]
¡@¡@End With
¡@¡@TT = TT & "/" & T
101: Next i
ActiveSheet.AutoFilterMode = False
End Sub

yen956

¦^´_ 13# ­ã´£³¡ªL
­ã¤j§A¦n!!
¤S¾Ç¨ì¤@©Û, ª½±µ
    Set Sht = Nothing
    If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
    On Error Resume Next
    Set Sht = Sheets(T)
    On Error GoTo 0
    If Sht Is Nothing Then
        Set Sht = Sheets.Add(After:=Sheets(Sheets.Count))
    End If
´N¥i¥H¤£¥²¥ý§PÂ_sht¬O§_¦s¦b,¯u°ª, ¦¬¤U, ÁÂÁÂ!!
¦ý½Ð°Ý InStr(TT & "/", "/" & T & "/")  ªº§@¥Î¬O¤°»ò?ÁÂÁÂ!!

lpk187

¦^´_ 14# yen956


    §Ú·QInStr(TT & "/", "/" & T & "/")ªº·N«ä¬°
·í²Ä¤@¦¸Åª¨ú¹Lªº¤u§@ªí¦WºÙ·|¼g¤J¨ìÅܼÆTTªº¦r¦ê¤¤¡A¦]¬°¤w¸g°µ¹L¿z¿ï¤F¡A©Ò¥H·í¦A¦¸Åª¨ú¨ì´¿°O¿ý¹Lªº¦WºÙ®É¸õ¹L
¦Ó"/"«h¬O­n°Ï¤À¦U¤u§@ªí¦Wªº°Ï¹j¡A¤£·|­«ÂСAÅýInStr®e©ö§PÂ_¡A¦Ó¤£·|²£¥Í¿ù»~ªº§PÂ_

­ã´£³¡ªL

¦^´_ 15# lpk187


§¹¥þ¥¿½T, ÁÂÁ¤j¥X¤O¸ÑÄÀ!

InStr(TT & "/", "/" & T & "/")¡@¥Î"/'¤À¹j¡A¥i¥H²M·¡¤À§O A AA AAA ©Î¡@A1 A11 A111¡A¦Ó¤£·|»~§P¡I¡I
¦Ó¥B²z½×¤W¡A¤u§@ªí¦WºÙ¤£·|¦³"/"¦r¤¸¡A­Y¥Î¨ä¥¦²Å¸¹¡A´N­n¦Ò¼{¤u§@ªíªí¦WºÙ¬O§_§t¦³³o­Ó²Å¸¹¡A
¨Ò¦p¡G¥Î"-"¤À¹j¡A´N¥i¯à¹ï 1-1   1-11   1-111  ¬Û¦ü¤u§@ªí»~§P¡I¡I

yen956

¦^´_ 16# ­ã´£³¡ªL
¦^´_ lpk187:
¦^´_ ­ã¤j:
ÁÂÁ¨â¦ì¸Ô²Óªº»¡©ú, ÁÂÁÂ!!

yen956

'·J¥X¨ì¤À­¶4(¯Â¦Û§Ú¾Ç²ß VBA ¥Î, §OµL¥¦·N):
'§ó·sª©, §ó·s­«ÂI¦p¤U:
'1. ¬JµM ÄæA¤Î[C3] §¡¬°¼È¦s°Ï, «hÀ³¾ã¦X¨ì¦P¤@Ä椤, ¬G[C3]À³§ï¨ì[A3]
'2. ¨â¦C*****¶¡ªº ²M°£¤À­¶ À³²¾ "¥Dµ{¦¡" ¦¡¤º, ¥iÁקK»~§R­«­n¸ê®Æ
'3. §ï¥Î­ã¤jªº·§©À, ¤£¥t§P§O¤À­¶¬O§_¦s¦b, §Y§R°£ Function shExist, ¥i¬Ù±¼¤£¤Ö°j°é
'
'§ó¥¿µ²ªG¦p¤U:
'½Ð¶K¨ì "·JÁ`ªí"

Sub ·J¥X¨ì¤À­¶4()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shName As String
    Dim i As Integer, J As Integer
    Lst1 = [B65536].End(xlUp).Row
   
    '¥[¤J­ì§Ç¸¹, ¤è«K«ì´_­ìª¬(¼È©ñÄæA,¥i§ï©ñ§OÄæ)
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '«ö¤u§@ªí¦WºÙ±Æ§Ç
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    '¥Dµ{¦¡
    For i = 5 To Lst1
        shName = Cells(i, 2)
        
        Set sh1 = Nothing
        On Error Resume Next
        Set sh1 = Sheets(shName)
        On Error GoTo 0
        
        '­Y sh1 ¤´¬° Nothing ¡÷ ¦W¬° shName ªº¤u§@ªí¨Ã¤£¦s¦b ¡÷ ¼W¥[·s¤u§@ªí
        If sh1 Is Nothing Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        sh1.Cells.Clear           '²M°£¤À­¶
        [B4:E4].Copy sh1.[B4]     '½Æ»s¼ÐÃD
        [A3].FormulaR1C1 = "=COUNTIF(C[1],""=""&R" & i & "C[1])"   '­pºâ¦P¦Wªº¤u§@ªí¦³´X­Ó
        Cells(i, 2).Resize([A3], 4).Copy sh1.[B5]                  '§å¦¸½Æ»s¦P¦Wªº¤u§@ªí
        i = i + [A3] - 1                '¸õ¨ì¤U­Ó¤£¦P¦W¤u§@ªí, ¬G¤£¥Î¿z¿ï
    Next
   
    '«ì´_­ìª¬ ¡÷ «ö­ì§Ç¸¹±Æ, ¨Ã²M°£¼È¦s°Ï
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear     '²M°£¼È¦s°Ï ÄæA
End Sub

Hsieh

1. Sub ex()
   
2. Dim ar(0 To 1), ay()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheets("·JÁ`ªí")
   
5. For Each a In .Range(.[B5], .[B5].End(xlDown))
   
6.    If IsEmpty(d(a & "")) Then
   
7.       ar(0) = Array(.[B4], .[C4], .[D4], .[E4])
   
8.       ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
   
9.       d(a & "") = ar
   
10.       Else
    
11.       ay = d(a & "")
    
12.       s = UBound(ay)
    
13.       ReDim Preserve ay(s + 1)
    
14.       ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
    
15.       d(a & "") = ay
    
16.       Erase ay
    
17.     End If
    
18. Next
    
19. For Each sh In Sheets
    
20.    If d.exists(sh.Name) = True Then
    
21.       ay = d(sh.Name)
    
22.       sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
    
23.       d.Remove sh.Name
    
24.     End If
    
25. Next
    
26. For Each ky In d.keys
    
27.    With Sheets.Add(after:=Sheets(Sheets.Count))
    
28.       .Name = ky
    
29.        ay = d(ky)
    
30.       .[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
    
31.     End With
    
32. Next
    
33. End With
    
34. End Sub

½Æ»s¥N½X

¦^´_ 1# ¾Ç¨ì¦Ñ¦º

c_c_lai

¦^´_ 19# Hsieh

1. sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))

½Æ»s¥N½X

°õ¦æ¨ì¦¹¦æ¡A§Y²£¥Í "«¬ºA¤£²Å (#13)"