Hsieh

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

1. Sub AddCheckBox() '¥[¤J®Ö¨ú¤è¶ô
   
2. '¦]¬°¨S¦³´£¨Ñ¤å¦rÀÉ¡A¥H²{¦³Item§@¬°·s¼W±ø¥ó
   
3. With Sheet1
   
4. .CheckBoxes.Delete
   
5. k = Application.CountIf(.Columns("E"), "ID")
   
6. Set A = .Columns("F").Find("Item", lookat:=xlPart)
   
7. For i = 1 To k
   
8.   With .CheckBoxes.Add(.Cells(i + 4, "C").Left, .Cells(i + 4, "C").Top, .Cells(i + 4, "C").Width, .Cells(i + 4, "C").Height)
   
9.      .Characters.Text = A
   
10.   End With
    
11.   Set A = .Columns("F").FindNext(A)
    
12. Next
    
13. End With
    
14. End Sub
    
15. Sub ¤ñ¹ï()
    
16. Dim Sp As Shape, Rng As Range, A As Range, MyRng As Range
    
17. With Sheet1
    
18.    For Each Sp In .Shapes
    
19.      If Sp.Name Like "Check Box*" Then
    
20.      Set A = .Columns("F").Find(Sp.OLEFormat.Object.Caption)
    
21.       If Sp.OLEFormat.Object.Value = 1 Then
    
22.       If Rng Is Nothing Then
    
23.          Set Rng = A.Offset(1, 0).Resize(5, 5)
    
24.          Else
    
25.          Set Rng = Union(Rng, A.Offset(1, 0).Resize(5, 5))
    
26.        End If
    
27.        End If
    
28.      End If
    
29.     Next
    
30.     Set MyRng = .[M3:Q7]
    
31. If Not Rng Is Nothing Then
    
32.   For i = 1 To 5
    
33.      For j = 1 To 5
    
34.      If MyRng(i, j) <> 0 And MyRng(i, j) <> "___" Then
    
35.        For Each ar In Rng.Areas
    
36.          If ar(i, j) = MyRng(i, j) Then p = p + 1
    
37.        Next
    
38.        s = p / Rng.Areas.Count: p = 0
    
39.        n = Application.Lookup(s, Array(0, 0.1, 0.2, 0.4, 0.6, 0.8, 1), Array(1, 2, 3, 4, 5, 6, 7))
    
40.        MyRng.Cells(i, j).Interior.ColorIndex = .[S2:Y2].Cells(1, n).Interior.ColorIndex
    
41.        Else
    
42.        MyRng.Cells(i, j).Interior.ColorIndex = -4142
    
43.     End If
    
44.      Next
    
45.   Next
    
46. End If
    
47. End With
    
48. End Sub

½Æ»s¥N½X

Hsieh

¦^´_  Hsieh


    ¹ê¦b¤j¤jªº·PÁÂHsieh ¶W¯Åª©¥Dªº³»¤O¨ó§U,½Ð°Ýª©¥D±z¤j·§¼g³o­Óµ{¦¡ªá¤F¦h¤Ö®É¶¡,¤p ...
cmo140497 µoªí©ó 2012-12-17 09:12

¥Î¦h¤Ö®É¶¡¨Ã¤£­«­n¡A¬O§_¹F¨ì»Ý¨D¤~¬O­«ÂI
¦Ü©óMyRng¬O­n¤ñ¹ï§ïÅÜÃC¦âªº°Ï°ì
¦Ü©ó§A­n¦h­Ó½d³ò´N¬Ý§Aªºªí®æ¤À§G³W«h¦Ó©w
¤W¶ÇÀɮ׸ոլݧa

Hsieh

¦^´_ 6# cmo140497


   ³o¼Ë¤w¸g¿ù¶Ã¤F¡A½Ð»¡©ú§Aªº¾ãÅé¬yµ{
©ÒªþªºtxtÀɮ׬O­n¼g¤JE:JÄæ¦ì©Î¬O­n©ñ¨ìM:QÄæ§@¬°¤ñ¹ïÅܦâÀx¦s®æ?
³o¨Ç¤å¦rÀɸê®Æ©Ò§Î¦¨ªº°}¦CÄæ¡B¦C¼Æ¥i¯à¬O¤£¦Pªº¡A¨º»òÃC¦â¹ï·Óªí[S2:Y2]ªº¦ì¸m¬O§_¤S­n§ïÅÜ?

Hsieh

¦^´_ 14# cmo140497
«D±`©êºp¡A§Ú¹ê¦b¬Ý¤£À´§A¾ãÅé¬yµ{»P©Ò»Ý®ÄªG
½Ð±Ð¥H¤U°ÝÃD
1¡B¤å¦rÀɪº¥Î·N¬O¬Æ»ò?
2¡B­nÅܦ⪺¦ì¸m¨ì©³¬O­þ­Ó¦ì¸m?
3¡B­nÅܦ⪺¦ì¸mªº¸ê®Æ¬O¦p¦ó¨ú±o?
4¡B½ÐºÉ¥i¯à±N±zªº©Ò¦³°Ê§@¬yµ{±Ô­z²M·¡
­n¥ÎÀɮ׸ÑÄÀ±zªº°ÝÃD¡A½Ð¥Î¤@­PªºÀÉ®×

Hsieh

¦^´_ 16# cmo140497
¤£ª¾¹D²z¸Ñ¬O§_¥¿½T
±N¤å¦rÀÉ»Pµ{¦¡Àɦܩó¦P¤@¸ê®Æ§¨¸Õ¸Õ
RawData.rar (26.7 KB)

¤U¸ü¦¸¼Æ: 14

2012-12-19 01:01

1. Sub InputData()
   
2. Dim Btn(), Mystr$, ARng As Range
   
3. fd = ThisWorkbook.Path & "\"
   
4. fs = Dir(fd & "*.txt")
   
5. With ActiveSheet
   
6. .CheckBoxes.Delete
   
7. .Cells.Clear
   
8. Do Until fs = ""
   
9. Open fd & fs For Input As #1
   
10.    Do While Not EOF(1)
    
11.      Line Input #1, Mystr
    
12.      If InStr(Mystr, ":") > 0 Then
    
13.      r = r + 1
    
14.        .Cells(r, 3) = Split(Mystr, ":")(0)
    
15.         If InStr(Split(Mystr, ":")(1), " ") > 0 Then
    
16.            ar = Split(Split(Mystr, ":")(1), " ")
    
17.            .Cells(r, 5).Resize(, UBound(ar) + 1) = ar
    
18.         Else
    
19.            .Cells(r, 5) = Replace(Split(Mystr, ":")(1), "ITEM", "")
    
20.            ReDim Preserve Btn(s)
    
21.            Btn(s) = Replace(Split(Mystr, ":")(1), "ITEM", "")
    
22.            s = s + 1
    
23.         End If
    
24.      End If
    
25.     Loop
    
26. Close #1
    
27. r = r + 1
    
28.     fs = Dir
    
29. Loop
    
30. .Cells(r, 5).Resize(, UBound(ar) + 1).EntireColumn.AutoFit
    
31. For i = 0 To s - 1
    
32.   With .CheckBoxes.Add(.Cells(i + 4, "A").Left, .Cells(i + 4, "A").Top, .Cells(i + 4, "A").Width, .Cells(i + 4, "A").Height)
    
33.      .Characters.Text = Btn(i)
    
34.      .OnAction = "Get_Rng"
    
35.   End With
    
36. Next
    
37. .Range(.Range(.[E2], .[E2].End(xlDown)), .Range(.[E2], .[E2].End(xlDown)).End(xlToRight)).Copy .[AI2]
    
38. .[AI2].CurrentRegion.EntireColumn.AutoFit
    
39. Set ARng = .[AI2].CurrentRegion
    
40. ARng.Replace "___", ""
    
41. ARng.SpecialCells(xlCellTypeConstants).Value = 0
    
42. ARng.SpecialCells(xlCellTypeBlanks).Value = "___"
    
43. End With
    
44. ActiveWindow.Zoom = 75
    
45. End Sub
    
46. Sub Get_Rng()
    
47. Dim A As Range, Rng As Range, Sp As Shape, CRng As Range
    
48. With ActiveSheet
    
49. For Each Sp In .Shapes
    
50. If Sp.Name Like "Check Box*" Then
    
51. If Sp.OLEFormat.Object.Value = 1 Then
    
52. n = Sp.OLEFormat.Object.Caption
    
53. Set A = .Columns("E").Find(n, lookat:=xlWhole)
    
54. If Rng Is Nothing Then
    
55.     Set Rng = A.CurrentRegion
    
56.     Else
    
57.     Set Rng = Union(Rng, A.CurrentRegion)
    
58. End If
    
59. End If
    
60. End If
    
61. Next
    
62. If Rng Is Nothing Then
    
63. MsgBox "Nothing"
    
64. Else
    
65. For x = 1 To Rng.Areas(1).Columns.Count
    
66.    For y = 2 To Rng.Areas(1).Rows.Count
    
67.    ReDim ay(1 To Rng.Areas.Count)
    
68.    ReDim ary(1 To Rng.Areas.Count)
    
69.       For i = 1 To Rng.Areas.Count
    
70.       If Rng.Areas(i).Cells(y, x) = "000" Then .[AI2].CurrentRegion.Cells(y - 1, x).Interior.ColorIndex = 4: GoTo 10
    
71.          ay(i) = Rng.Areas(i).Cells(y, x)
    
72.       Next
    
73.       For j = 1 To UBound(ay)
    
74.          For s = 1 To UBound(ay)
    
75.            If ay(j) = ay(s) Then cnt = cnt + 1
    
76.          Next
    
77.          ary(j) = cnt: cnt = 0
    
78.       Next
    
79.       g = Application.Lookup(Application.Max(ary) / Rng.Areas.Count, Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1), Array(4, 44, 8, 6, 7, 3, 16))
    
80.       With .[AI2].CurrentRegion.Cells(y - 1, x)
    
81.       If .Value = "___" Then
    
82.          .Interior.ColorIndex = -4142
    
83.          Else
    
84.          .Interior.ColorIndex = g
    
85.        End If
    
86.        End With
    
87. 10
    
88.     Next
    
89. Next
    
90. End If
    
91. End With
    
92. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 19# cmo140497

1. Sub Get_Rng()
   
2. Dim A As Range, Rng As Range, Sp As Shape, CRng As Range
   
3. With ActiveSheet
   
4. For Each Sp In .Shapes
   
5. If Sp.Name Like "Check Box*" Then
   
6. If Sp.OLEFormat.Object.Value = 1 Then
   
7. n = Sp.OLEFormat.Object.Caption
   
8. Set A = .Columns("E").Find(n, lookat:=xlWhole)
   
9. If Rng Is Nothing Then
   
10.     Set Rng = A.CurrentRegion
    
11.     Else
    
12.     Set Rng = Union(Rng, A.CurrentRegion)
    
13. End If
    
14. End If
    
15. End If
    
16. Next
    
17. If Rng Is Nothing Then
    
18. MsgBox "Nothing"
    
19. Else
    
20. For x = 1 To Rng.Areas(1).Columns.Count
    
21.    For y = 2 To Rng.Areas(1).Rows.Count
    
22.    ReDim ay(1 To Rng.Areas.Count)
    
23.    ReDim ary(1 To Rng.Areas.Count)
    
24.       For i = 1 To Rng.Areas.Count
    
25.          ay(i) = Rng.Areas(i).Cells(y, x)
    
26.          If Rng.Areas(i).Cells(y, x) = "000" Then zero = zero + 1
    
27.       Next
    
28.       For j = 1 To UBound(ay)
    
29.          For s = 1 To UBound(ay)
    
30.            If ay(j) = ay(s) Then cnt = cnt + 1
    
31.          Next
    
32.          ary(j) = cnt: cnt = 0
    
33.       Next
    
34.       g = Application.Lookup(Application.Max(ary) / Rng.Areas.Count, Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1), Array(4, 44, 8, 6, 7, 3, 16))
    
35.       With .[AI2].CurrentRegion.Cells(y - 1, x)
    
36.       If .Value = "___" Then
    
37.          .Interior.ColorIndex = -4142
    
38.          ElseIf zero = Rng.Areas.Count Then '¥þ³¡³£¬O000
    
39.          .Interior.ColorIndex = 4
    
40.          Else
    
41.          .Interior.ColorIndex = g
    
42.        End If
    
43.        zero = 0
    
44.        End With
    
45. 10
    
46.     Next
    
47. Next
    
48. End If
    
49. End With
    
50. End Sub

½Æ»s¥N½X