[µo°Ý] ¸ê®Æª½¦VÂà¾î¦V±Æ¦C

Genie

¤£¦n·N«ä¤S¨Ó¸ß°Ý¤F

§Ú±q¸ê®Æ®w§ì¥X¨Óªº¸ê®Æ¦pªþ¥óªº"­ì©l¸ê®Æ"©Ò¥Ü¡@§e²{ªº¬Oª½¦V±Æ¦C
­Y§Ú­n±N¸ê®ÆÂàÅܦ¨ªþ¥ó¤¤"Âà¸m«á"ªº¼Ë¤l
¤£ª¾¬O§_¦³¿ìªk¹F¨ì¡H

¦]¬°§Ú§ì¥X¨Óªº¸ê®Æ¦C¼Æ³£¹F¨ì¤W¸Uµ§
©Ò¥H¬O§Æ±æ¯à¦b·sªº sheet °µÂà¸m¡@¶¶«K«O¯d­ì©l¸ê®Æ¥i¥H°µ°Ñ¦Ò

­Y¥H A Äæ¨Ó·í§@¸s²Õ§@Âà¸m¡@«h A Ä檺"1"¡B"2"¡B"3"¦U¤À§O¬°¤@¸s²Õ
¼ÐÃD´N¥H"1"¡B"2"¡B"3"·í§@¼ÐÃD
­Y¥H B Äæ¨Ó·í§@¸s²Õ§@Âà¸m¡@«h B Ä檺"4"¡B"5"¡B"6"¦A·f°t A Ä檺"1"¡B"2"¡B"3"§@¬°¤@¸s²Õ
¼ÐÃD´N¥H"A-B"¨Ó·í§@¼ÐÃD¡@¦]¦¹¼ÐÃD´N¬O"1-4"¡B"1-5"¡B"1-6"¡B"2-4"¡B2-5"¡B"2-6"¡B"3-4"¡B"3-5"¡B"3-6"

§Æ±æ¥i¥HÀ°À°§Ú¡@ÁÂÁ¡ã

¸ê®Æ.zip (4.42 KB)

¤U¸ü¦¸¼Æ: 35

2013-1-7 11:30

mark15jill

¦^´_ 1# Genie
¤ñ¸û°ò¦ªº¼gªk

1. Sub oag()
   
2. 
   
3. Range("g2:az20000").Clear  '¦¹¦æ¥i§R°£ ¥D­n¬O¥Î¨Ó²M°£¦h¾l­«½Æªº
   
4. 
   
5. For uua = 1 To 3
   
6.     For uub = 4 To 6
   
7.             For uud = 2 To Range("a2").CurrentRegion.Rows.Count
   
8.                 Select Case uua
   
9.                     Case 1
   
10.                     If Cells(uud, 1) = uua Then Cells(uud, uua + 22) = Cells(uud, 3)
    
11.                     Select Case uub
    
12.                         Case uub
    
13.                         If Cells(uud, 1) = uua And Cells(uud, 2) = uub Then Cells(uud, uua + 21 + uub) = Cells(uud, 3)
    
14.                     End Select
    
15.                
    
16.                     Case 2
    
17.                     If Cells(uud, 1) = uua Then Cells(uud, uua + 22) = Cells(uud, 3)
    
18. 
    
19.                     Select Case uub
    
20.                         Case uub
    
21.                         If Cells(uud, 1) = uua And Cells(uud, 2) = uub Then Cells(uud, uua + 23 + uub) = Cells(uud, 3)
    
22.                     End Select
    
23.                     Case 3
    
24.                     If Cells(uud, 1) = uua Then Cells(uud, uua + 22) = Cells(uud, 3)
    
25.                     Select Case uub
    
26.                         Case uub
    
27.                         If Cells(uud, 1) = uua And Cells(uud, 2) = uub Then Cells(uud, uua + 25 + uub) = Cells(uud, 3)
    
28.                     End Select
    
29.                 End Select
    
30.             Next
    
31.     Next
    
32. Next
    
33. For aaa = 1 To Range("a2").CurrentRegion.Rows.Count
    
34.     For uus = 23 To 34
    
35.         For uuk = 2 To Range("a2").CurrentRegion.Rows.Count
    
36.             If Cells(2, uus) = "" Then
    
37.                 Cells(2, uus).Select
    
38.                 Selection.Delete Shift:=xlUp
    
39.             End If
    
40.         Next
    
41.     Next
    
42. Next
    
43. 
    
44. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 1# Genie
¸Õ¸Õ¬Ý

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D(1 To 2) As Object, AR(), Rng As Range, i As Integer, K As Variant
   
4.     Set D(1) = CreateObject("SCRIPTING.DICTIONARY")   '¦r¨åª«¥ó
   
5.     Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
   
6.     Set Rng = Sheets("­ì©l¸ê®Æ").Range("a2")          'Àx¦s®æª«¥ó
   
7.     Do
   
8.         '1. ¨Ì·Ó A Äæ§@°Ï¤À¡A±N¸ê®Æ¥Ñª½¦V±Æ¦CÅܬ°¾î¦V±Æ¦C¡C
   
9.         '2. ­Y¨Ì A Äæ§@°Ï¤À¡A´N¥H A Ä檺­È§@¬°¼ÐÃD¡C
   
10.         If D(1).exists(Rng.Value) Then                      '¦r¨åª«¥ó.exists(Rng.Value) ÃöÁä¦r[¦s¦b] ±ø¥ó¦¨¥ß
    
11.            AR = D(1)(Rng.Value)                             '°}¦C=¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e
    
12.            ReDim Preserve AR(UBound(D(1)(Rng.Value)) + 1)   '°}¦CÂX¥R¼W¥[¤@¤¸¯À
    
13.            AR(UBound(AR)) = Rng.Cells(1, 3).Value           '°}¦C¼W¥[ªº¤¸¯À=CÄ檺¼Æ­È
    
14.            D(1)(Rng.Value) = AR                             '¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e=°}¦C
    
15.         Else
    
16.             D(1)(Rng.Value) = Array(Rng.Cells(1, 3).Value)  '¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e=°}¦C
    
17.         End If
    
18.         '*********************************************
    
19.         '1. ¨Ì·Ó B Äæ§@°Ï¤À¡A±N¸ê®Æ¥Ñª½¦V±Æ¦CÅܬ°¾î¦V±Æ¦C¡C
    
20.         '2. ­Y¨Ì B Äæ§@°Ï¤À¡A´N¥H A-B Ä檺­È§@¬°¼ÐÃD
    
21.         K = "'" & Rng & " - " & Rng.Cells(1, 2)
    
22.         If D(2).exists(K) Then
    
23.            AR = D(2)(K)
    
24.            ReDim Preserve AR(UBound(D(2)(K)) + 1)
    
25.            AR(UBound(AR)) = Rng.Cells(1, 3).Value
    
26.            D(2)(K) = AR
    
27.         Else
    
28.             D(2)(K) = Array(Rng.Cells(, 3).Value)
    
29.         End If
    
30.         Set Rng = Rng.Offset(1)
    
31.     Loop Until Rng = ""
    
32.     With Sheets("sheet1")
    
33.         .Cells.Clear
    
34.         If D(1).Count > 0 Then
    
35.             i = 1
    
36.             For Each K In D(1).keys    'K= ¦r¨åª«¥ó(ÃöÁä¦r)
    
37.                 .Cells(1, i) = K
    
38.                 .Cells(2, i).Resize(UBound(D(1)(K)) + 1) = Application.WorksheetFunction.Transpose(D(1)(K))  'Ū¨ú¤º®e
    
39.                 i = i + 1
    
40.             Next
    
41.         End If
    
42.         If D(2).Count > 0 Then
    
43.             i = 10
    
44.             For Each K In D(2).keys
    
45.                 .Cells(1, i) = K
    
46.                 .Cells(2, i).Resize(UBound(D(2)(K)) + 1) = Application.WorksheetFunction.Transpose(D(2)(K))
    
47.                 i = i + 1
    
48.             Next
    
49.         End If
    
50.     End With
    
51. End Sub

½Æ»s¥N½X

Genie

¦^´_ 2# mark15jill


ÁÂÁ¡ã
¤£¹LÁöµM¥i¥H¦¨¥\°µ¥X¨Ó¡@¦ý¦]§Úªº¸ê®Æ¶q«ÜÃe¤j
°õ¦æ°_¨Ó³t«×«D±`ºC¡@¤£ª¾¬O§_¦³§ïµ½¤èªk¡H
¦Ó¥B§Ú¤@¦¸¥u·|¿ï¾Ü¤@Äæ (A Äæ©Î B Äæ) ¨Ó°µ¤À²Õ
¨Ã¤£»Ý­n¤@¦¸´N±N¿ï¾Ü¨âÄ檺±¡ªp°õ¦æ¥X¨Ó
¥t¥~¡@¸ê®Æ¨C¦¸Âà¸m«áªºÄæ¦ì¥i¨ì¤T¡B¥|¤QÄæ
©Ò¥H§Ú§Æ±æ¯à¦b·s sheet °õ¦æÂà¸m«áªºµ²ªG
½Ð°Ý¦³¿ìªk¶Ü¡H

Genie

¦^´_ 3# GBKEE


ÁÂÁ¡ã¡@¦¨¥\°µ¥X§Ú·Q­nªº¸ê®Æ®æ¦¡¤F¡I¡I¡I
¤£¹L§Ú¤@¦¸¥u·|¿ï¾Ü¤@Äæ (A Äæ©Î B Äæ) ¨Ó°µ¤À²Õ
¨Ã¤£»Ý­n¤@¦¸´N±N¿ï¾Ü¨âÄ檺±¡ªp°õ¦æ¥X¨Ó
©Ò¥H¬O§_¦³¿ìªkÅý§Ú¤@¶}©l´N¿ï¾Ü­n¨Ï¥Î A Äæ©Î B Äæ¨Ó°µ¤À²ÕÂà¸m§Úªº¸ê®Æ©O¡H

GBKEE

¦^´_ 5# Genie

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, AR(), Rng As Range, i As Integer, K As Variant, W As String
   
4.     Do
   
5.         W = InputBox("½Ð¿ï¾Ü: A Äæ§@°Ï¤À ©Î B Äæ§@°Ï¤À")
   
6.         If W = "" Then Exit Sub                         '¨S¿é¤J:Â÷¶}µ{¦¡
   
7.     Loop Until UCase(W) = "A" Or UCase(W) = "B"
   
8.     Set D = CreateObject("SCRIPTING.DICTIONARY")        '¦r¨åª«¥ó
   
9.     Set Rng = Sheets("­ì©l¸ê®Æ").Range("a2")            'Àx¦s®æª«¥ó
   
10.     Do
    
11.         If UCase(W) = "A" Then K = Rng.Value
    
12.         If UCase(W) = "B" Then K = "'" & Rng & " - " & Rng.Cells(1, 2)
    
13.         If D.exists(K) Then                             '¦r¨åª«¥ó.exists(Rng.Value) ÃöÁä¦r[¦s¦b] ±ø¥ó¦¨¥ß
    
14.             AR = D(K)                                   '°}¦C=¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e
    
15.             ReDim Preserve AR(UBound(D(K)) + 1)         '°}¦CÂX¥R¼W¥[¤@¤¸¯À
    
16.             AR(UBound(AR)) = Rng.Cells(1, 3).Value      '°}¦C¼W¥[ªº¤¸¯À=CÄ檺¼Æ­È
    
17.             D(K) = AR                                   '¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e=°}¦C
    
18.         Else
    
19.             D(K) = Array(Rng.Cells(1, 3).Value)         '¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e=°}¦C
    
20.         End If
    
21.         Set Rng = Rng.Offset(1)
    
22.     Loop Until Rng = ""
    
23.     With Sheets("Âà¸m«á")
    
24.         .Cells.Clear
    
25.         If D.Count > 0 Then
    
26.             i = 1
    
27.             For Each K In D.keys    'K= ¦r¨åª«¥ó(ÃöÁä¦r)
    
28.                 .Cells(1, i) = K
    
29.                 .Cells(2, i).Resize(UBound(D(K)) + 1) = Application.WorksheetFunction.Transpose(D(K))  'Ū¨ú¤º®e
    
30.                 i = i + 1
    
31.             Next
    
32.         End If
    
33.     End With
    
34. End Sub

½Æ»s¥N½X

c_c_lai

¦^´_ 6# GBKEE
¦^´_ 5# Genie
GBKEE ª©¤j¦­¦w¡I
¤µ¦­Åª¤F "¸ê®Æª½¦VÂà¾î¦V±Æ¦C" µoı Idea ¤£¿ù¡A©ó¬O¥G
°£¤F­ì¥ýªº  "AÄæ¡BB Äæ" ¡A§Ú¤S¥[¤J¤F "AB Äæ" ¿ï¶µ¡C
¨Ó¨ú¼Ö¤@¤U¡A½Ð¤Å¨£©Ç¡I(§Ú¥t¼W¥[¤@¤u§@ªí³æ "´ú¸Õµ²ªG")

1. Sub Ex2()
   
2.     Dim D As Object, AR(), Rng As Range, i As Integer, K As Variant, W As String
   
3.     Dim cts As Integer, nums As Integer
   
4.    
   
5.     '  Do
   
6.     '      W = InputBox("½Ð¿ï¾Ü: A Äæ§@°Ï¤À ©Î B Äæ§@°Ï¤À")
   
7.     '      If W = "" Then Exit Sub                         '  ¨S¿é¤J:Â÷¶}µ{¦¡
   
8.     '  Loop Until UCase(W) = "A" Or UCase(W) = "B"
   
9.     W = InputBox("½Ð¿ï¾Ü: A Äæ§@°Ï¤À ©Î B Äæ§@°Ï¤À¡B" & vbCrLf & "¥ç©Î¬O AB Äæ§@°Ï¤À")
   
10.     If UCase(W) <> "A" And UCase(W) <> "B" And UCase(W) <> "AB" Then Exit Sub   '  ¨S¿é¤J:Â÷¶}µ{¦¡
    
11.    
    
12.     nums = IIf(UCase(W) = "AB", 2, 1)
    
13.     Set D = CreateObject("Scripting.Dictionary")            '  ¦r¨åª«¥ó
    
14.    
    
15.     For cts = 1 To nums
    
16.         Set Rng = Sheets("­ì©l¸ê®Æ").Range("a2")            '  Àx¦s®æª«¥ó
    
17.         
    
18.         Do
    
19.            If UCase(W) = "AB" Then
    
20.                 K = IIf(cts = 1, Rng.Value, "'" & Rng & " - " & Rng.Cells(1, 2))
    
21.             Else
    
22.                 K = IIf(UCase(W) = "A", Rng.Value, "'" & Rng & " - " & Rng.Cells(1, 2))
    
23.             End If
    
24.                
    
25.             If D.exists(K) Then                             '  ¦r¨åª«¥ó.exists(Rng.Value) ÃöÁä¦r[¦s¦b] ±ø¥ó¦¨¥ß
    
26.                 AR = D(K)                                   '  °}¦C=¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e
    
27.                 ReDim Preserve AR(UBound(D(K)) + 1)         '  °}¦CÂX¥R¼W¥[¤@¤¸¯À
    
28.                 AR(UBound(AR)) = Rng.Cells(1, 3).Value      '  °}¦C¼W¥[ªº¤¸¯À=CÄ檺¼Æ­È
    
29.                 D(K) = AR                                   '  ¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e=°}¦C
    
30.             Else
    
31.                 D(K) = Array(Rng.Cells(1, 3).Value)         '  ¦r¨åª«¥ó(ÃöÁä¦r)ªº¤º®e=°}¦C
    
32.             End If
    
33.             Set Rng = Rng.Offset(1)
    
34.         Loop Until Rng = ""
    
35.     Next
    
36.             
    
37.     With Sheets("´ú¸Õµ²ªG")
    
38.         .Cells.Clear
    
39.             
    
40.         If D.Count > 0 Then
    
41.             i = 1
    
42.             For Each K In D.keys                            '  K = ¦r¨åª«¥ó(ÃöÁä¦r)
    
43.                 .Cells(1, i) = K
    
44.                 .Cells(2, i).Resize(UBound(D(K)) + 1) = Application.WorksheetFunction.Transpose(D(K))  '  Åª¨ú¤º®e
    
45.                 i = i + 1
    
46.             Next
    
47.         End If
    
48.     End With
    
49. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 1# Genie

1. Sub ex()
   
2. Dim A As Range, d As Object, j&, i%, s%, C$, Ky
   
3. C = InputBox("¿é¤JÄæ¦ìA©ÎB", , "A")
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. With Sheet1
   
6. j = 2
   
7. Do Until .Cells(j, 1) = ""
   
8.   Set A = .Cells(j, C)
   
9.   s = Application.CountIf(.Range(A, A.End(xlDown)), A)
   
10.   i = Application.CountIf(A.Resize(s, 1), .Cells(j, C)) '­pºâ³æµ§¸ê®Æ¶q
    
11.   If C = "A" Then
    
12.      d(A.Value) = A.Offset(, 2).Resize(i, 1).Value
    
13.      Else
    
14.      d(A.Offset(, -1) & "_" & A) = A.Offset(, 1).Resize(i, 1).Value
    
15.   End If
    
16. j = j + i
    
17. Loop
    
18. End With
    
19. With Sheet2
    
20. .UsedRange.Clear
    
21. k = 1
    
22. For Each Ky In d.keys
    
23.    .Cells(1, k) = Ky
    
24.    .Cells(2, k).Resize(i, 1) = d(Ky)
    
25.    k = k + 1
    
26. Next
    
27. End With
    
28. End Sub

½Æ»s¥N½X

Genie

¦^´_ 6# GBKEE
¦^´_ 7# c_c_lai


ÁÂÁ¡ã¡@µ{¦¡°õ¦æ°_¨Ó¨S¦³°ÝÃD¡I¡I¡I

¦A½Ð°Ý¡@­Y§Ú­nÂX¥RÄæ¦ì¡@¥Î C Äæ©Î D Äæ§@°Ï¤À
¦³¿ìªk¤p§ï³o­Óµ{¦¡´N°µ±o¨ì¶Ü¡H

ÁöµM¥Ø«e¥Î¤£¨ì¡@¦ý·Q¤F¸Ñ¥¼¨Ó¦³»Ý­n®É§Ú¥i¥H«ç¼Ë°µ§ï¼g
ÁÂÁ¡ã

Genie

¦^´_ 8# Hsieh


³o­Óµ{¦¡°õ¦æ°_¨Ó¡@¦³´X­Ó¼Æ¾Ú·|µLªkÂà¸m¦¨¥\
¥B·|¥X²{ ¡­N/A ªºÄæ¦ì
¦p¹Ï¬O¿ï A Äæ¶i¦æÂà¸m
¦b "1" Ä椤¤Ö¤F¤@­Ó¼Æ¾Ú¡@¦b "2" Ä椤¦h¤F #N/A
½Ð°Ý¦³¿ìªk§ïµ½¶Ü¡H
ÁÂÁ¡ã

¤U¸ü (37.81 KB)

2013-1-8 14:16