Hsieh

¦^´_ 1# tonycho33

1. Sub Âà¸m()
   
2. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
   
3. With Sheets("a")
   
4. For Each A In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
   
5. Ar = A.Resize(, 4)
   
6. Ay = .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight).Offset(2)).Value
   
7. For i = 1 To UBound(Ay, 2)
   
8. ReDim Preserve Ary(7, s)
   
9. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4)
   
10.    For j = 1 To UBound(Ay, 1)
    
11.    Ary(j + 1, s) = Ay(j, i)
    
12.    Next
    
13.    s = s + 1
    
14. Next
    
15. Next
    
16. End With
    
17. Sheets("b").UsedRange.Offset(1) = ""
    
18. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary)
    
19. End Sub

½Æ»s¥N½X

sheet Äæ¦ìÂà´«.rar (11.01 KB)

¤U¸ü¦¸¼Æ: 26

2011-12-20 19:15

Hsieh

¦^´_ 9# tonycho33


    sheet Äæ¦ìÂà´«.rar (13.16 KB)

¤U¸ü¦¸¼Æ: 13

2011-12-21 18:04

Hsieh

¦^´_ 11# tonycho33

1. Sub Âà¸m()
   
2. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
   
3. With Sheets("a")
   
4. For Each A In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants) '¦bA2¥H¤U¦³¸ê®ÆªºÀx¦s®æ°µ°j°é
   
5. Ar = A.Resize(, 4) 'AÄæ¦V¥kÂX®i¦¨Ä檺½d³ò¡A¨ú±o¤u³æ¡B®Æ¸¹¡BºK­n¡B¼Æ¶q
   
6. Ay = .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight).Offset(2)).Value '±qGÄæ¦V¥k¨ì¸Ó¦C¸ê®Æ§À¦V¤U2¦Cªº½d³ò¦s¤J°}¦CÅܼÆ
   
7. For i = 1 To UBound(Ay, 2) '°j°é±q1¶}©l¨ì¸ê®Æ°}¦CªºÄæ¼Æ
   
8. ReDim Preserve Ary(7, s) '¡AÂX®i°ÊºA°}¦C¦¹°}¦C¦³7¦C¡AÂX®i¦¨sÄæ
   
9. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4) '±N¤u³æ¡B®Æ¸¹¡B¼Æ¶q¼g¤J°}¦C
   
10.    For j = 1 To UBound(Ay, 1)
    
11.    Ary(j + 1, s) = Ay(j, i) '±N¨C­Ó¤uµ{ªº3­Ó¶µ¥Ø¼g¤J°}¦C
    
12.    Next
    
13.    s = s + 1 '·Ç³Æ¤U¦¸°ÊºA°}¦CÂX¼WªºÄæ¼Æ
    
14. Next
    
15. Next
    
16. End With
    
17. Sheets("b").UsedRange.Offset(1) = "" '²MªÅ­ì¨Ó¸ê®Æ
    
18. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary) '±N°}¦C¼g¤Jb¤u§@ªí
    
19. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 13# tonycho33

§Aªº¶µ¥Ø­«½Æ¡A½Ð»¡©ú¤ñ¹ï³W«h

Hsieh

¦^´_ 16# tonycho33

ªí®æªº¦X¨ÖÀx¦s®æ°ÝÃD

1. Sub Âà¸m()
   
2. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
   
3. r = 2
   
4. With Sheets("a")
   
5. Do Until .Cells(r, 1) = ""
   
6. Set A = .Cells(r, 1)
   
7. Ar = A.Resize(, 4)
   
8. k = Application.CountA(.Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight)))
   
9. Ay = A.Offset(, 6).Resize(3, k).Value
   
10. For i = 1 To UBound(Ay, 2)
    
11. ReDim Preserve Ary(7, s)
    
12. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4)
    
13.    For j = 1 To UBound(Ay, 1)
    
14.    Ary(j + 1, s) = Ay(j, i)
    
15.    Next
    
16.    s = s + 1
    
17. Next
    
18. r = r + 3
    
19. Loop
    
20. End With
    
21. Sheets("b").UsedRange.Offset(1) = ""
    
22. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary)
    
23. End Sub
    
24. 
    
25. Private Sub Worksheet_Activate()
    
26. Set d = CreateObject("Scripting.Dictionary")
    
27. With Sheet6
    
28. For Each A In .Range("J:J").SpecialCells(xlCellTypeConstants)
    
29.    If A = "ok" Then
    
30.    mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -9).Resize(, 5).Value)), "")
    
31.    d(mystr) = d.Count
    
32.    End If
    
33. Next
    
34. End With
    
35. With Me
    
36. r = 2
    
37. Do Until .Cells(r, 1) = ""
    
38. Set A = .Cells(r, 1)
    
39. mystr = A & A.Offset(, 1)
    
40.    For Each c In .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight))
    
41.       temp = mystr & Join(Application.Transpose(c.Resize(3, 1)), "")
    
42.       If d.exists(temp) = True Then c.Resize(3, 1).Interior.ColorIndex = 38 Else c.Resize(3, 1).Interior.ColorIndex = 0
    
43.    Next
    
44. r = r + 3
    
45. Loop
    
46. End With
    
47. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 28# tonycho33

1. Sub Âà¸m()
   
2. 
   
3. Dim A As Range, Ar(), Ay(), i%, j%, Ary(), s&
   
4. 
   
5. r = 2
   
6. 
   
7. With Sheets("a")
   
8. 
   
9. Do Until .Cells(r, 1) = ""
   
10. 
    
11. Set A = .Cells(r, 1)
    
12. 
    
13. Ar = A.Resize(, 4)
    
14. 
    
15. k = Application.CountA(.Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight)))
    
16. If k = 0 Then GoTo 10
    
17. Ay = A.Offset(, 6).Resize(3, k).Value
    
18. 
    
19. For i = 1 To UBound(Ay, 2)
    
20. 
    
21. ReDim Preserve Ary(7, s)
    
22. 
    
23. Ary(0, s) = Ar(1, 1): Ary(1, s) = Ar(1, 2): Ary(6, s) = Ar(1, 4)
    
24. 
    
25.    For j = 1 To UBound(Ay, 1)
    
26. 
    
27.    Ary(j + 1, s) = Ay(j, i)
    
28. 
    
29.    Next
    
30. 
    
31.    s = s + 1
    
32. 
    
33. Next
    
34. 10
    
35. r = r + 3
    
36. 
    
37. Loop
    
38. 
    
39. End With
    
40. 
    
41. Sheets("b").UsedRange.Offset(1) = ""
    
42. 
    
43. Sheets("b").[A2].Resize(s, 7) = Application.Transpose(Ary)
    
44. 
    
45. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 31# tonycho33

¸Õ¸Õ¬Ý

1. Private Sub Worksheet_Activate()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Set d1 = CreateObject("Scripting.Dictionary")
   
4. With Sheet6
   
5. For Each A In .Range("I2", .[I65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
   
6.    If A <> "" And A.Offset(, 1) = "" Then
   
7.    mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -8).Resize(, 5).Value)), "")
   
8.    d(mystr) = d(mystr) + 1
   
9.    ElseIf A.Offset(, 1) - A Then
   
10.    mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -8).Resize(, 5).Value)), "")
    
11.    d1(mystr) = d1(mystr) + 1
    
12.    End If
    
13. Next
    
14. End With
    
15. With Me
    
16. r = 2
    
17. Do Until .Cells(r, 1) = ""
    
18. Set A = .Cells(r, 1)
    
19. mystr = A & A.Offset(, 1)
    
20.    For Each c In .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight))
    
21.       temp = mystr & Join(Application.Transpose(c.Resize(3, 1)), "")
    
22.       If d.exists(temp) = True Then
    
23.       c.Resize(3, 1).Interior.ColorIndex = 4
    
24.       ElseIf d1.exists(temp) = True Then
    
25.       c.Resize(3, 1).Interior.ColorIndex = 6
    
26.       Else
    
27.       c.Resize(3, 1).Interior.ColorIndex = 0
    
28.       End If
    
29.    Next
    
30. r = r + 3
    
31. Loop
    
32. End With
    
33. End Sub

½Æ»s¥N½X