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

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

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

¥»©«³Ì«á¥Ñ GBKEE ©ó 2012-12-17 15:51 ½s¿è

Dear ¦U¦ìª©¥D©Î°ª¤â¤j¤j­Ì :
  ¤p§Ì¥ý«e½Ð±Ð¹L¦U¦ìª©¥D¤Î¤j¤jªº¤@¨Ç¥¨¶°ªº°ÝÃD,¤]·PÁ¦U¦ìªº¤£§[«ü±Ð,¤µ¦³¤@­Ó°ÝÃD,¤w¸g·Ð¤F§Ö¤@­Ó¤ë,¤w¹M¾ú°ê¥~¦U¤jºô¯¸vba©Î¨ç¼Æªº¨Ò¤l,¤´µLªk¸Ñ¨M§xÂZ¤w¤[ªº°ÝÃD
§Æ±æ¥i¥H±q¦U¦ìª©¥D©Î°ª¤â¤j¤j­Ì´M±o¨ó§U,ÁÂÁÂ!
¥H¤U¤¶²Ð´X­Óºô¯¸ÁÙº¡¤£¿ùªº:
http://www.get-digital-help.com/category/excel/table/
http://chandoo.org/wp/2009/03/25/using-array-formulas-example1/
http://www.contextures.com/tiptech.html

¤p§Ì·Q¨Ì«ü©w¸ô®|¤U¤§¸ê®Æ§¨§ä¨ì¸ê®Æ§¨¤º¤§ÀÉ®×,§@¦Û°Ê·s¼W®Ö¨ú¤è¶ô¼Æ¶q,¦p¥H¤U¹Ï¤ù¦³3­Ó¤å¦rÀɤº®e¤w³Q¤p§Ì¸ü¤Jexcel¤º,­n¦p¦ó¤ñ¸û¦Uµ§¤§¬Û¦P¦ì§}¤§¸ê®Æ,¬O§_­«ÂÐ?¦p¦³
­«ÂШípºâ­«ÂЦ¸¼Æ°£¥H®Ö©w¤ù¼Æ,§@¦Ê¤À¤ñ¤§®æ¦¡¤Æ±ø¥óªºÃC¦â¤ÀÃþ,¦p¤U¹Ï©Ò¥Ü



´M§ä¦U²Õ¼Æ¬Û¦P¦ì¤§¬O§_­«ÂЩοW¥ß¤§¼Æ­È§@¦Ê¤À¤ñ®æ¦¡¤Æ±ø¥ó.zip (13.93 KB)

¦^´_ 21# Hsieh


    ¦A«×·PÁª©¥D,¹ê¦b·P®¦,ÁÂÁÂ!

TOP

¦^´_ 22# GBKEE

Dear GBKEE ª©¥D :
¹ê¦b¤£¦n·N«ä°Õ,¨Ã¤£¬O¦³·Nªº,¯uªº«Ü·PÁª©¥D¤Î¦b³o¸Ìªº°ª¤â­Ì´À¤p§Ì¸Ñ¨M§xÂZ,¤p§Ì¤]·|±q³o¨Çµo°Ý¤¤¾Ç¨ì¤£¤ÖÀ³¥Î,¯uªº«Ü·PÁª©¥D±zªºÀ°¦£,·P®¦!

TOP

¥»©«³Ì«á¥Ñ GBKEE ©ó 2012-12-20 09:44 ½s¿è

16# Àɮתºµ{¦¡½X,¸Õ¬Ý¬Ýµ{¦¡³B¸Ìªº³t«×¬O§_º¡·N!!
  1. Option Explicit
  2. Const xRow As Integer = 24
  3. Const xCol As Integer = 24
  4. Private Sub AUTO_OPEN()
  5.     Dim Rng As Range, E As Range, xi As Integer
  6.     Sheets("Overlap").Activate
  7.     Set Rng = [A:A]
  8.     Rng.Replace "ID", "=XXX", xlWhole
  9.     Set Rng = Rng.SpecialCells(xlCellTypeFormulas, xlErrors)
  10.     ActiveSheet.CheckBoxes.Delete
  11.     For Each E In Rng.Cells
  12.         With Cells(xi + 5, "AA")
  13.             With ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
  14.                 .Caption = "Item" & xi + 1
  15.                 .OnAction = "Ex_Action"
  16.                 E.Offset(1, 1).Resize(xRow, xCol).Name = "_" & .Caption  '³]¸m½d³ò¦WºÙ
  17.             End With
  18.         End With
  19.         xi = xi + 1
  20.     Next
  21.     Rng.Value = "ID"
  22. End Sub
  23. Private Sub Ex_Action()
  24.     Dim cBox As Object, Rng As Range, r As Integer, y As Integer, xi As Integer
  25.     Dim Ar(), E As Variant, t As Date
  26.     t = Time
  27.     For Each cBox In ActiveSheet.CheckBoxes
  28.         If cBox.Value = 1 Then
  29.             If Rng Is Nothing Then Set Rng = Range("_" & cBox.Caption)
  30.             If Not Rng Is Nothing Then Set Rng = Union(Rng, Range("_" & cBox.Caption))
  31.         End If
  32.     Next
  33.     With Range("AI5").Resize(xRow, xCol)
  34.         .Interior.ColorIndex = xlNone
  35.         For Each cBox In .Cells
  36.             If cBox <> "___" Then cBox = 0
  37.         Next
  38.     End With
  39.     Application.ScreenUpdating = False
  40.     Range("B:Z").Interior.ColorIndex = xlNone
  41.     If Rng Is Nothing Then Exit Sub
  42.     ReDim Ar(1 To xRow, 1 To xCol)                                      '³]©w:°}¦C¤j¤p
  43.     '********  ¨C¤@­Ó½d³ò¤¤¦P¤@¦ì¸m¦³¸ê®Æªº:­p¼Æ
  44.     For Each cBox In Rng.Areas                                          '³B¸Ì¨C¤@­Ó½d³ò
  45.         For r = 1 To xRow
  46.             For y = 1 To xCol
  47.                 If cBox(r, y) = "___" Then GoTo 0                       '¤£³B¸Ì
  48.                 If cBox(r, y) <> 0 Then Ar(r, y) = Ar(r, y) + 1         '¬ö¿ý¸ê®Æ
  49. 0:
  50.             Next
  51.         Next
  52.     Next
  53.     '********  ¨C¤@­Ó½d³ò¤¤¦P¤@¦ì¸m¸ê®Æªº­p¼Æ¦Ê¤À¤ñ:³]¤UÃC¦â
  54.     For Each cBox In Rng.Areas
  55.         For r = 1 To xRow
  56.             For y = 1 To xCol
  57.                 xi = 0                                                  '¦Ê¤À¤ñ:Âk¹s
  58.                 If cBox(r, y) = "___" Then GoTo 1
  59.                 For Each E In Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1)
  60.                     xi = xi + 1
  61.                     If Ar(r, y) / Rng.Areas.Count <= E Then Exit For    '¨ú±o¦Ê¤À¤ñ
  62.                 Next
  63.                 If Ar(r, y) > 0 Then cBox(r, y).Interior.ColorIndex = [AA2].Cells(1, xi).Interior.ColorIndex
  64.                                                                         '[AA2].Cells(1, xi):ÃC¦âªº¦ì¸m
  65. 1:
  66.             Next
  67.         Next
  68.     Next
  69.     '********  ²Î­p½d³ò¦ì¸m¸ê®Æ: ­p¼Æ, ¦Ê¤À¤ñÃC¦â
  70.     With Range("AI5")
  71.         For r = 1 To xRow
  72.             For y = 1 To xCol
  73.                 If .Cells(r, y) <> "___" Then
  74.                     .Cells(r, y) = IIf(Ar(r, y) = "", 0, Ar(r, y))
  75.                     If Ar(r, y) > 0 Then
  76.                     .Cells(r, y).Interior.ColorIndex = Rng(r, y).Interior.ColorIndex
  77.                     Else
  78.                     .Cells(r, y).Interior.ColorIndex = [AA2].Interior.ColorIndex
  79.                     End If
  80.                 End If
  81.             Next
  82.         Next
  83.     End With
  84.     Application.ScreenUpdating = True
  85.     MsgBox Format(t, "¶}©l hh:mm:ss") & vbLf & Format(Time, "µ²§ô hh:mm:ss") & vbLf & vbLf & Format(Time - t, "¶O®É hh:mm:ss")
  86. End Sub
½Æ»s¥N½X
¦^´_ 19# cmo140497

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

ÁöµLÅv­­¤U¸ü...¤´ÁÂÁ±zªº¤À¨É...
§V¤O¼W¥[µ¥¯Å¤¤...

TOP

¦^´_ 17# Hsieh


    Dear Hsiehª©¥D :
    ¤£¦n·N«ä,¦A«×¥´ÂZ±z¤@¤U,·PÁª©¥D±z´£¨Ñ¨ó§U,¤p§Ì´ú¸Õ¤F¤@¤U,¦³ÂI¤p¤pªºbug,¤£ª¾±z¬O§_¥i¥H¦AÀ°¤p§Ìdebug¤@¤U,¥D­n¦b¬Û°£¥À¼Æ,¦ü¥G§â¥k¦C¶È±ýÅã¥Üªº¹Ï­È,¥[¶i¨Ó¤F,Åܦ¨¥ô¦ó­È»P0¤ñ¸û,§¡Åܬ°0,·P®¦


TOP

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

¦^´_ 17# Hsieh

·PÁª©¥D¤£§[«ü±Ð,³o¼Ë¬Ý°_¨Ó¯uªºÂ²³æ¦h¤F,¹ï©ó±zªº¤j®¦¤j¼w,¤p§Ì²¦¥ÍÃø§Ñ,¤Ó·PÁ±z¤F,ÁÂÁÂ!

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

¦^´_ 15# Hsieh


    Dear Hsieh ª©¥D :
    ¹ê¦b¤£¦n·N«ä,³y¦¨±zªº§xÂZ,§Æ±æ±z¥i¨£½Ì..Ãö©ó±zªººÃ°Ý
1¡B¤å¦rÀɪº¥Î·N¬O¬Æ»ò?
       ³o¤å¦rÀÉ¥Nªí¤@­Ó²£«~ªºÀˬdµ²ªG,¤p§Ì·Qª¾¹D¥¦»P¨ä¥¦¶¡¦³¨S¦³¶°¤¤©Î­«Å|ªºÁͶÕ,ÂÇ¥H¤F¸Ñ¨Ã¸Õ§ä¥X¥i¯à¬O­þ¤@­Ó¬yµ{¥X°ÝÃD
2¡B­nÅܦ⪺¦ì¸m¨ì©³¬O­þ­Ó¦ì¸m?
      §Æ±æ¬O¥i¥H¦b©T©w¦ì¸mRange("AI5:BF28"),¦Ó¤£¬O¨C­Ó¤å¦rÀɪº¦ì¸m,¤£¦n·N«ä,¤p§Ì¨S¦³»¡©ú²M·¡,©êºp
3¡B­nÅܦ⪺¦ì¸mªº¸ê®Æ¬O¦p¦ó¨ú±o?
      ©Ò¥H¤p§ÌÅܧó¬yµ{,¤T­ÓID¬Û¦P¦ì§}¥u­n¦³<>0,«h­pºâ1,¤T­Ó³£<>0,«h­pºâ3,±N3°£¥H®Ö¨ú¤è¶ô¤Ä¿ïªº¤ù¼Æ3=100%,«h¥H100%¤§ÃC¦â
      ¶ñ¤J­nÅܦ⪺¦ì¸m§Y¥i,¤ð»Ý¦A¥Î¤å¦rÀɤ§¸ê®Æ»P­nÅܦ⤧¸ê®Æ§@¤ñ¹ï¤F,¤£ª¾³o¼Ë¬O§_¥i¦æ?
4¡B½ÐºÉ¥i¯à±N±zªº©Ò¦³°Ê§@¬yµ{±Ô­z²M·¡
    ¤£¦n·N«ä,¦]¬°¤W¯Z¥Î¤½¥q¹q¸£,¦³ÂILag,¤W¶Ç¸ê®Æ¦³®É©Ç©Çªº,³y¦¨±zªº§xÂZ,¹ê¦b©êºp

§Æ±æª©¥D¦AÀ°¦£¬Ý¤@¤U,·P®¦,ÁÂÁÂ!


¦h²Õ¼Æ¤§¤¸¯À­«ÂЦ¸¼Æ¤ñ¸û¨Ã§@±ø¥ó®æ¦¡¤Æ_2012-12-18.zip (25.28 KB)

TOP

        ÀR«ä¦Û¦b : ÀR§¤±`®¦¤v¹L¡B¶¢½Í²ö½×¤H«D¡C
ªð¦^¦Cªí ¤W¤@¥DÃD