ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ¦p¦ó¨Ï¥ÎVBA©Î¨ç¼Æ°µ¦h­Ó°}¦C¼Æ­Èªº¤ñ¸û¤Î®æ¦¡¤Æ±ø¥óªº³]©w

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_  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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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§ïÅÜ?
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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ªºÀÉ®×
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 16# cmo140497
¤£ª¾¹D²z¸Ñ¬O§_¥¿½T
±N¤å¦rÀÉ»Pµ{¦¡Àɦܩó¦P¤@¸ê®Æ§¨¸Õ¸Õ
RawData.rar (26.7 KB)
  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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

        ÀR«ä¦Û¦b : ¡i»X½ªªº¦Û¥Ñ¡j¤H±`¦b¤°»ò³£¥i¥H¦Û¥Ñ¦Û¦bªº®É­Ô¡A«o³Q³oºØÀH¤ß©Ò±ýªº¦Û¥Ñ»X½ª¡AµêÂY®É¥ú¦Ó²@µLıª¾¡C
ªð¦^¦Cªí ¤W¤@¥DÃD