Hsieh

¦^´_ 4# candy516
³Ì¥D­n¬O¬Ý¤£À´§A©Ò¿×°£Åv®§ªº¼Ð¬O­n¶ñ¦b­þ¸Ì?
½Ð¸ÕÁ|¨Ò¨Ó»¡©ú¡A§A¸ê®Æ­n«ç»ò¶ñªk

Hsieh

¦^´_ 6# candy516

§Ú¤£À´ªº¬O¡ASheet1°O¸ü¬O2010/9/7  ¬O°£Åv¤é
¦ý©p±Ô­z®É¤S¬OÅܦ¨2010/9/8
­Y±ø¥ó¨S¦¨¥ß¬O©¹«e§ä©Î¬O©¹«á§ä
§ä¨ì«á­n¦bC85¼g¤J¤°»ò­È?
¸U¤@°£Åv«á³£¨S¦^¤É¤S¸Ó¦p¦ó?

Hsieh

¦^´_ 8# candy516

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.ScreenUpdating = False
   
4. With Sheet1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       d(a & Year(a.Offset(, 1))) = Array(a.Offset(, 1), a.Offset(, 2))
   
7.    Next
   
8. End With
   
9. For y = 2001 To 2010
   
10.   With Sheets(CStr(y))
    
11.     If Application.CountBlank(.Range(.[B1], .[IV1].End(xlToLeft))) > 0 Then .Range(.[B1], .[IV1].End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
12.     .Range(.[IV1].End(xlToLeft).Offset(, 1), .[IV1]).EntireColumn.Clear
    
13.     k = 2
    
14.     Do Until .Cells(1, k) = ""
    
15.     .Columns(k + 1).Insert
    
16.        mystr = .Cells(1, k) & y
    
17.        Set a = .Columns("A").Find(d(mystr)(0))
    
18.        If Not a Is Nothing Then
    
19.        cnt = 0
    
20.          r = a.Row
    
21.          test = .Cells(r - 1, k)
    
22.          r = r + 1
    
23.          cnt = cnt + 1
    
24.          Do Until .Cells(r, k) >= test Or .Cells(r, k) = ""
    
25.          cnt = cnt + 1
    
26.          r = r + 1
    
27.          Loop
    
28.          If .Cells(r, 1) = "" Then
    
29.          .Cells(a.Row, k + 1) = "µL¶ñÅv"
    
30.          Else
    
31.          .Cells(a.Row, k + 1) = cnt
    
32.          End If
    
33.        End If
    
34.        k = k + 2
    
35.     Loop
    
36.   End With
    
37. Next
    
38. Application.ScreenUpdating = True
    
39. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 10# candy516

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.ScreenUpdating = False
   
4. With Sheet1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       d(a & Year(a.Offset(, 1))) = a.Offset(, 1).Value
   
7.    Next
   
8. End With
   
9. For y = 2001 To 2010
   
10.   With Sheets(CStr(y))
    
11.     If Application.CountBlank(.Range(.[B1], .[IV1].End(xlToLeft))) > 0 Then .Range(.[B1], .[IV1].End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
12.     .Range(.[IV1].End(xlToLeft).Offset(, 1), .[IV1]).EntireColumn.Clear
    
13.     k = 2
    
14.     Do Until .Cells(1, k) = ""
    
15.     .Columns(k + 1).Insert
    
16.        mystr = .Cells(1, k) & y
    
17.        Set a = .Columns("A").Find(d(mystr))
    
18.        If Not a Is Nothing Then
    
19.        cnt = 0
    
20.          r = a.Row
    
21.          test = .Cells(r + 1, k)
    
22.          cnt = cnt + 1
    
23.          Do Until .Cells(r, k) >= test Or .Cells(r, k) = ""
    
24.          cnt = cnt + 1
    
25.          r = r - 1
    
26.          Loop
    
27.          If r <= 2 Then
    
28.          .Cells(a.Row, k + 1) = "µL¶ñÅv"
    
29.          Else
    
30.          .Cells(a.Row, k + 1) = cnt
    
31.          End If
    
32.        End If
    
33.        k = k + 2
    
34.     Loop
    
35.   End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 12# candy516

¦]¬°Äæ¼Æ¹L¦h¥²¶·¨Ï¥Î2007ª©¥»

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.ScreenUpdating = False
   
4. With Sheet1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       d(a & Year(a.Offset(, 1))) = a.Offset(, 1).Value
   
7.    Next
   
8. End With
   
9. For y = 2001 To 2004
   
10.   With Sheets(CStr(y))
    
11.     If Application.CountBlank(.Range(.[B1], .[XFD1].End(xlToLeft))) > 0 Then .Range(.[B1], .[XFD1].End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
12.     .Range(.[XFD1].End(xlToLeft).Offset(, 1), .[XFD1]).EntireColumn.Clear
    
13.     k = 2
    
14.     Do Until .Cells(1, k) = ""
    
15.     .Columns(k + 1).Insert
    
16.        mystr = .Cells(1, k) & y
    
17.        Set a = .Columns("A").Find(d(mystr))
    
18.        If Not a Is Nothing Then
    
19.        cnt = 0
    
20.          r = a.Row
    
21.          test = .Cells(r + 1, k)
    
22.          cnt = cnt + 1
    
23.          Do Until .Cells(r, k) >= test Or .Cells(r, k) = ""
    
24.          cnt = cnt + 1
    
25.          r = r - 1
    
26.          Loop
    
27.          If r <= 2 Then
    
28.          .Cells(a.Row, k + 1) = "µL¶ñÅv"
    
29.          Else
    
30.          .Cells(a.Row, k + 1) = cnt
    
31.          End If
    
32.        End If
    
33.        k = k + 2
    
34.     Loop
    
35.   End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 15# candy516

¨º­n¬Ý§Aªº®æ¦¡¬O§_¸ò¨ä¥L¦~«×¤@¼Ë

Hsieh

¦^´_ 19# candy516
¤ñ¸û¦nªº¤è¦¡¬O§â©Ò¦³¦~«×¸ê®Æ³£¾ã²z¦b¦P¤@¤u§@ªí¤¤
¸ó¦~¸ó¤ëªº°ÝÃD´N®e©ö¸Ñ¨M

Hsieh

¦^´_ 22# candy516
³o¼Ë¥i¯à³Â·Ð¤@ÂI
µ{¦¡±N¶ñ¤J¶ñÅv¤é¼Æ¡A¨Ã±N10¤é¤º¶ñÅv¦W³æ¦C¥X
½Ð±Nµ{¦¡½X¸m©óSheet1¼Ò²Õ

1. Sub ¶ñÅv()
   
2. Dim A As Range, Ar()
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. Set myday = CreateObject("Scripting.Dictionary")
   
5.           ReDim Preserve Ar(z)
   
6.           Ar(z) = Array("¤½¥q", "¦~«×", "¶ñÅv¤é¼Æ")
   
7.           z = z + 1
   
8. 
   
9. Dim Sh As Worksheet
   
10. For j = Sheets.Count To 1 Step -1
    
11. Set Sh = Sheets(j)
    
12.   With Sh
    
13.      If .Name <> Me.Name Then
    
14.      Set rng = .Range(.[B1], .Cells(1, .Columns.Count).End(xlToLeft))
    
15.         If Application.CountBlank(rng) > 0 Then rng.SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
16.         For r = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1
    
17.         Set A = .Cells(r, 1)
    
18.            myday(A.Value) = temp
    
19.            temp = A.Value
    
20.         Next
    
21.         Else
    
22.         For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(3))
    
23.         dic(A & Year(A.Offset(, 1))) = A.Offset(, 1)
    
24.         Next
    
25.     End If
    
26.   End With
    
27. Next
    
28. For Each Sh In Sheets
    
29.   With Sh
    
30.   If .Name < Me.Name Then
    
31.   k = 2: dn = .Name
    
32.     Do Until .Cells(1, k) = ""
    
33.        .Columns(k + 1).Insert
    
34.        f = .Cells(1, k)
    
35.        Set A = .Columns("A").Find(dic(f & dn))
    
36.        If A Is Nothing Then GoTo 20
    
37.        d = myday(A.Value)
    
38.        With Sheets(CStr(Year(d)))
    
39.           Set b = .Columns("A").Find(d)
    
40.           Set c = .Rows(1).Find(f)
    
41.           If b Is Nothing Or c Is Nothing Then cnt = "µL¶ñÅv": GoTo 10
    
42.           x = b.Row
    
43.           y = c.Column
    
44.           test = .Cells(x, y)
    
45.        End With
    
46.        r = A.Row: cnt = 1
    
47.        Do Until r = 2 Or .Cells(r, k) >= test
    
48.        r = r - 1
    
49.        cnt = cnt + 1
    
50.        Loop
    
51.        If r = 2 Then cnt = "µL¶ñÅv"
    
52. 10
    
53.        .Cells(A.Row, k + 1) = cnt
    
54.        If IsNumeric(cnt) And cnt <= 10 Then
    
55.           ReDim Preserve Ar(z)
    
56.           Ar(z) = Array(f, dn, cnt)
    
57.           z = z + 1
    
58.        End If
    
59.       
    
60. 20
    
61.        k = k + 2
    
62.     Loop
    
63.   End If
    
64.   End With
    
65. Next
    
66. Set dic = Nothing
    
67. Set myday = Nothing
    
68. With Worksheets.Add
    
69. .[A1].Resize(z, 3) = Application.Transpose(Application.Transpose(Ar))
    
70. .Move
    
71. End With
    
72. End Sub

½Æ»s¥N½X