c_c_lai

¦^´_ 5# ¾Ç¨ì¦Ñ¦º
®M¥Î yen956 ¤j¤jªº²{¦¨µ{¦¡¡G

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.    
   
7.     Set sh1 = Sheets("·JÁ`ªí")
   
8.     sh1.Cells.Clear
   
9.    
   
10.     For J = 1 To Sheets.Count
    
11.         If Sheets(J).Name <> "·JÁ`ªí" Then
    
12.             Set sh2 = Sheets(J)
    
13.             Lst1 = sh1.[B65536].End(xlUp).Row + 1
    
14.            '  sh2.UsedRange.Address = "$B$4:$E$7" : String
    
15.            '  sh2.UsedRange.Offset(1, 0).Address = "$B$5:$E$8" : String
    
16.            sh2.UsedRange.Offset(1, 0).Copy sh1.Cells(Lst1, 2)
    
17.         End If
    
18.     Next
    
19. End Sub

½Æ»s¥N½X

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

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)"

c_c_lai

¦^´_ 19# Hsieh

1. Sub ex()                     '  Hsieh
   
2.     Dim ar(0 To 1), ay(), txt$, rng As Range, cts As Integer
   
3.    
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.    
   
6.     With Sheets("·JÁ`ªí")
   
7.         For Each a In .Range(.[B2], .[B2].End(xlDown))
   
8.             If IsEmpty(d(a & "")) Then
   
9.                 ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
   
10.                 ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
    
11.                 d(a & "") = ar      '  a & "" §Yµ¥©ó CStr(a)¡C ±N a : Variant Âà´«¬° String «¬ºA
    
12.             Else
    
13.                 ay = d(a & "")
    
14.                 s = UBound(ay)
    
15.                 ReDim Preserve ay(s + 1)
    
16.                 ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
    
17.                 d(a & "") = ay
    
18.                 Erase ay
    
19.             End If
    
20.             '  d(CStr(a)) = Array(d(CStr(a)), a.Resize(, 4).Value)
    
21.             '  a & "" §Yµ¥©ó CStr(a)¡C ±N a : Variant Âà´«¬° String «¬ºA
    
22.         Next     '  d.Count = 3 : Variant/Long
    
23.         
    
24.         For Each sh In Sheets    '  sh : Variant/Object/¤u§@ªí1/¤u§@ªí8
    
25.             If sh.Name <> "·JÁ`ªí" And d.exists(sh.Name) = True Then
    
26.                 ay = d(sh.Name)
    
27.                
    
28.                 '  sh.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
    
29.                 '  ª½¦æ¦Ü¤W¤@¦æ«h²£¥Í ¡y°õ¦æ¶¥¬q¡G 13 ¡u«¬ºA¤£²Å¡v¡z¡A¬G§ï¥H¤U¦C»yªk³B¸Ì¡G
    
30.                 Set rng = sh.[B1]
    
31.                 Sheets("·JÁ`ªí").[B1:E1].Copy rng
    
32.                 For cts = 1 To UBound(ay)
    
33.                     rng.Offset(cts).Resize(1, 4) = Application.Transpose(Application.Transpose(ay(cts)))
    
34.                 Next cts
    
35.                 d.Remove sh.Name
    
36.             End If
    
37.         Next               '  d.Count = 0 : Variant/Long
    
38.         
    
39.         For Each ky In d.keys
    
40.             With Sheets.Add(after:=Sheets(Sheets.Count))
    
41.                 .Name = ky
    
42.                 ay = d(ky)
    
43.                
    
44.                 '  .[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
    
45.                 '  ª½¦æ¦Ü¤W¤@¦æ«h²£¥Í ¡y°õ¦æ¶¥¬q¡G 13 ¡u«¬ºA¤£²Å¡v¡z¡A¬G§ï¥H¤U¦C»yªk³B¸Ì¡G
    
46.                 Set rng = .[B1]
    
47.                 Sheets("·JÁ`ªí").[B1:E1].Copy rng
    
48.                 For cts = 1 To UBound(ay)
    
49.                     rng.Offset(cts).Resize(1, 4) = Application.Transpose(Application.Transpose(ay(cts)))
    
50.                 Next cts
    
51.             End With
    
52.         Next
    
53.     End With
    
54. End Sub

½Æ»s¥N½X

c_c_lai

¦^´_ 19# Hsieh
²×©ó§ì¨ì°ÝÃDÄpµ²¤F¡A³s¹ÚºÎ¤¤¤]¦b±Ì´e¡C

1. ar(0) = Array(.[B1], .[C1], .[D1], .[E1])

½Æ»s¥N½X

.[B1] ¶Ç¤Jªº¬O Range ª«¥ó¡A¦Ó«D¦r¦ê¡F ¬G·|³y¦¨ ¡y°õ¦æ¶¥¬q¡G 13 ¡u«¬ºA¤£²Å¡v¡z¡A¬G§ï¥H¤U¦C»yªk³B¸Ì¡G

1. ar(0) = Array(.[B1].Value & "", .[C1].Value, .[D1].Value, .[E1].Value)

½Æ»s¥N½X

¨ä¥¦¤º®eºû«ù¤£ÅÜ¡C

1. Sub ex()                     '  Hsieh
   
2.     Dim ar(0 To 1), ay()
   
3.    
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.    
   
6.     With Sheets("·JÁ`ªí")
   
7.         For Each a In .Range(.[B2], .[B2].End(xlDown))
   
8.             If IsEmpty(d(a & "")) Then
   
9.                 '  ar(0) = Array(.[B1], .[C1], .[D1], .[E1])
   
10.                 '  .[B1] ¶Ç¤Jªº¬O Range ª«¥ó¡A¦Ó«D¦r¦ê¡F ¬G·|³y¦¨ ¡y°õ¦æ¶¥¬q¡G 13 ¡u«¬ºA¤£²Å¡v¡z¡A¬G§ï¥H¤U¦C»yªk³B¸Ì¡G
    
11.                 ar(0) = Array(.[B1].Value & "", .[C1].Value, .[D1].Value, .[E1].Value)
    
12.                 ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
    
13.                 d(a & "") = ar      '  a & "" §Yµ¥©ó CStr(a)¡C ±N a : Variant Âà´«¬° String «¬ºA
    
14.             Else
    
15.                 ay = d(a & "")
    
16.                 s = UBound(ay)
    
17.                 ReDim Preserve ay(s + 1)
    
18.                 ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
    
19.                 d(a & "") = ay
    
20.                 Erase ay
    
21.             End If
    
22.         Next
    
23.         
    
24.         For Each sh In Sheets  
    
25.             If d.exists(sh.Name) = True Then
    
26.                 ay = d(sh.Name)
    
27.                 sh.Cells.Clear
    
28.                
    
29.                 sh.[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
    
30.                 d.Remove sh.Name
    
31.             End If
    
32.         Next               '  d.Count = 0 : Variant/Long
    
33.         
    
34.         For Each ky In d.keys
    
35.             With Sheets.Add(after:=Sheets(Sheets.Count))
    
36.                 .Name = ky
    
37.                 ay = d(ky)
    
38.                
    
39.                 .[B1].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
    
40.             End With
    
41.         Next
    
42.     End With
    
43. End Sub

½Æ»s¥N½X

c_c_lai

¦^´_ 24# ¤d·u´M
³o¬O§Úªº§@·~¤ß±o³ø§i¡A©Î³\¯àÀ°§U§A¶i¤@¨B¤§¤F¸Ñ¡A
±N¥¦¶K¤W´£¨Ñ°Ñ¦Ò¡A¦b¦¹½gijÃD¤¤§Úı±o­ã¤jªº¸ÑÃD
¥Ó½×«D±`¤§´Î¡A³æ¤M¤Á¤Jª½±µ¤F·í¡A¤@´ª§Y¦¨¡C
¦b¦¹¥ç·PÁ ­ã´£³¡ªLª©¤j ªº¤£§[«ü¾É¡C

1. '  ¿z¿ïªk¡I¡I¡I      ­ã´£³¡ªL
   
2. '  ¨Ï¥Î¦¹¤èªk "·JÁ`ªí" ¤§ªì©l¤º®e¤£¶·¥ý¦æ±Æ§Ç (Sorting)¡A¥ç§Y¦b«O«ù­ì©lª¬ªp¤Uª½±µ¶i¦æ¿z¿ï³B¸Ì
   
3. Sub ex2()
   
4.     Dim xArea As Range, i&, T$, TT$, Sht As Worksheet
   
5.    
   
6.     With Sheets("·JÁ`ªí")
   
7.         .Select
   
8.         Set xArea = .Range([B1], Cells(Rows.Count, "B").End(xlUp)(1, 4))
   
9.         '  xArea : Range/Range  :  xArea.Address = "$B$1:$E$7" :  String
   
10.     End With
    
11.    
    
12.     For i = 2 To xArea.Rows.Count         '  xArea.Rows.Count : 7 : Long,  xArea.DataSeries : True : Variant/Boolean
    
13.         T = xArea(i, 1): Set Sht = Nothing           '  i = 2 : Long
    
14.         '  -------------------------------------------------------------------------
    
15.         '  ¬°Æ[¹î InStr(TT & "/", "/" & T & "/") ¥H¤Î TT = TT & "/" & T ªº³B²z¤è¦¡¡A
    
16.         '  ¯S±N "·JÁ`ªí" ¤º®e¤§¶¶§Ç¨Æ¥ý¹w§@½Õ¾ã¦p¤U¡A¥H¤è«K°»´ú TT ¹Lµ{¤¤§êºtªº¨¤¦â¡C
    
17.         '  -------------------------------------------------------------------------
    
18.         '  2(i) : xArea(i, 1) = "A" :  xArea(i, 2) = "­»¿¼" :  xArea(i, 3) = 10 :  xArea(i, 4) = 100 : Variant/Object/Range
    
19.         '  3(i) : xArea(i, 1) = "B" :  xArea(i, 2) = "«C´Ô" :  xArea(i, 3) = 50 :  xArea(i, 4) = 500 : Variant/Object/Range
    
20.         '  4(i) : xArea(i, 1) = "A" :  xArea(i, 2) = "¸²µå" :  xArea(i, 3) = 30 :  xArea(i, 4) = 300 : Variant/Object/Range
    
21.         '  5(i) : xArea(i, 1) = "B" :  xArea(i, 2) = "»ñ±ù" :  xArea(i, 3) = 40 :  xArea(i, 4) = 400 : Variant/Object/Range
    
22.         '  6(i) : xArea(i, 1) = "C" :  xArea(i, 2) = "ªÝ¼Ö" :  xArea(i, 3) = 60 :  xArea(i, 4) = 600 : Variant/Object/Range
    
23.         '  7(i) : xArea(i, 1) = "A" :  xArea(i, 2) = "Ä«ªG" :  xArea(i, 3) = 20 :  xArea(i, 4) = 200 : Variant/Object/Range
    
24.         
    
25.         If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
    
26.         '  ----------------------------------------------------------------------------------------------
    
27.         '  2(i) : TT & "/" = "/" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/")           = 0 : Long
    
28.         '  3(i) : TT & "/" = "/A" : "/" & T & "/" = "/B/" : InStr(TT & "/", "/" & T & "/")         = 0 : Long
    
29.         '  4(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/")     = 1 : Long
    
30.         '  5(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/B/" : InStr(TT & "/", "/" & T & "/")     = 1 : Long
    
31.         '  6(i) : TT & "/" = "/A/B" : "/" & T & "/" = "/C/" : InStr(TT & "/", "/" & T & "/")     = 0 : Long
    
32.         '  7(i) : TT & "/" = "/A/B/C" : "/" & T & "/" = "/A/" : InStr(TT & "/", "/" & T & "/") = 1 : Long
    
33.         '  ----------------------------------------------------------------------------------------------
    
34.         '  InStr(TT & "/", "/" & T & "/") ªº·N«ä¬°·í²Ä¤@¦¸Åª¨ú¹Lªº¤u§@ªí¦WºÙ·|¼g¤J¨ìÅÜ¼Æ TT ªº¦r¦ê¤¤,
    
35.         '  ¦]¬°¤w¸g°µ¹L¿z¿ï¤F, ©Ò¥H·í¦A¦¸Åª¨ú¨ì´¿°O¿ý¹Lªº¦WºÙ®É¸õ¹L, ¦Ó "/"  «h¬O­n°Ï¤À¦U¤u§@ªí¦Wªº°Ï¹j¡A
    
36.         '  ¤£·|­«ÂСAÅý InStr ®e©ö§PÂ_¡A¦Ó¤£·|²£¥Í¿ù»~ªº§PÂ_¡F
    
37.         '  InStr(TT & "/", "/" & T & "/")¡@¥Î "/' ¤À¹j¥i¥H²M·¡¤À§O A, AA, AAA ©Î A1, A11, A111¡A¦Ó¤£·|»~§P¡I
    
38.         '  ¦Ó¥B²z½×¤W, ¤u§@ªí¦WºÙ¤£·|¦³ "/" ¦r¤¸¡A­Y¥Î¨ä¥¦²Å¸¹¡A´N­n¦Ò¼{¤u§@ªíªí¦WºÙ¬O§_§t¦³³o­Ó²Å¸¹¡A
    
39.         '  ¨Ò¦p¡G ¥Î "-" ¤À¹j¡A´N¥i¯à¹ï 1-1, 1-11, 1-111  ³y¦¨¬Û¦ü¤u§@ªí¦WºÙ¤§»~§P¡I¡I
    
40.         '  ----------------------------------------------------------------------------------------------
    
41.         On Error Resume Next
    
42.         
    
43.         Set Sht = Sheets(T)
    
44.         On Error GoTo 0
    
45.         
    
46.         If Sht Is Nothing Then Set Sht = Sheets.Add(after:=Sheets(Sheets.Count)): Sht.Name = T   '  Sht ¤£¦s¦b
    
47.         Sht.UsedRange.Clear
    
48.         
    
49.         With xArea
    
50.             .Parent.Select     ' xArea.Parent.Name = "·JÁ`ªí" : Variant/String
    
51.             .AutoFilter Field:=1, Criteria1:=T   ' T = "A" : T = "B" :  T = "C" : String
    
52.             '  AutoFilter ·|¨Ì¾Ú Criteria1 ªº±ø¥ó¶×¶°¡A¼ÐÃD¦ì¸m¨Ã¤£·|²§°Ê
    
53.             .Copy Sht.[B1]                 '  ¥]§t¼ÐÃD»P¤º®e¤@¤@½Æ»s¨ì "A"¡B"B"¡B"C" ¦U§Oªº¤u§@ªí³æ¤º
    
54.         End With
    
55.         
    
56.         TT = TT & "/" & T       '  TT = "/A" : TT = "/A/B" :  TT = "/A/B/C" ¡G String  (§PÂ_¦r¦ê TT ³v¤@¼W¥[)
    
57. 101:
    
58.     Next i
    
59.    
    
60.     ActiveSheet.AutoFilterMode = False         '  ¦^´_¨ì­ì©l³Ìªìªº "·JÁ`ªí" ¤§±Æ§Ç«e¤º®e¶¶§Ç
    
61. End Sub

½Æ»s¥N½X

c_c_lai

¦^´_ 27# ¤d·u´M
¥t¤@ºØ¼¶¼g¤è¦¡¡G ¤£¨Ï¥Î GoTo 101 ªº¤èªk
¦]¦­´Á¦b¼¶¼g¤K¦ì¤¸¡B¤Î¤Q¤»¦ì¤¸µ{¦¡®É
(¥]§t Digital Research ªº CBasic)¡A´X¥G
ºÉ¶qÁקK¥h¨Ï¥Î  GoTo Syntax¡A§Ú§Q¥Î­ã¤j
ªº²{¦¨µ{¦¡¨Ó§ï¼g¦¨¦p¤U¡A½Ð°Ñ¦Ò¨Ï¥Î¤è¦¡¡G

1.     For i = 2 To xArea.Rows.Count
   
2.         T = xArea(i, 1): Set Sht = Nothing
   
3.         
   
4.         '  If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
   
5.         If T <> "" And InStr(TT & "/", "/" & T & "/") = 0 Then
   
6.             '
   
7.             '
   
8.             '
   
9.             '
   
10.             '
    
11.             '
    
12.             TT = TT & "/" & T
    
13.         End If   '  ª½±µ¨Ï¥Î If Then ~ End If ªº³B²z¼Ò¦¡
    
14. '  101:          '  ±N¥¦§ï¦¨ªþµù
    
15.     Next i

½Æ»s¥N½X