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

¸Û¨D«üÂI Get Cell Color ¤½¦¡ marco

¸Û¨D«üÂI Get Cell Color ¤½¦¡ marco



getcellcolor.rar (2.54 KB)

¦^´_ 1# jakcy1234
¸Õ¸Õ¬Ý
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng(1 To 3) As Range, E As Range, T As Single, i As Integer, R_Add As String
  4.     Set Rng(1) = Sheet1.[b24:b25]
  5.     Set Rng(2) = Sheet1.[b2:f20]
  6.     For Each E In Rng(1)
  7.         Application.FindFormat.Interior.ColorIndex = E.Interior.ColorIndex
  8.         'FindFormat ³]©w©Î¶Ç¦^­n´M§ä¤§Àx¦s®æ®æ¦¡Ãþ«¬ªº·j´M·Ç«h¡C
  9.         Set Rng(3) = Rng(2).Find(What:="", SearchFormat:=True)
  10.         If Not Rng(3) Is Nothing Then R_Add = Rng(3).Address
  11.         i = 0
  12.         T = 0
  13.         Do While Not Rng(3) Is Nothing
  14.            i = i + 1
  15.            T = T + Rng(3)
  16.            Set Rng(3) = Rng(2).Find(What:="", After:=Rng(3), SearchFormat:=True)
  17.            If R_Add = Rng(3).Address Then Exit Do
  18.         Loop
  19.         E.Offset(, 1) = T
  20.         E.Offset(, 2) = i
  21.     Next
  22.     Application.FindFormat.Clear  ' ²M°£ FindFormat ³]©w­n´M§ä¤§Àx¦s®æ®æ¦¡Ãþ«¬ªº·j´M·Ç«h¡C
  23. End Sub
½Æ»s¥N½X
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

¦^´_ 2# GBKEE
  1. '---------------------------------------------------------------------
  2. ' ColorIndex Function
  3. '---------------------------------------------------------------------
  4. ' Function:    Returns the colorindex of the supplied range
  5. ' Synopsis:    Initially, gets a colorindex value for black and white
  6. '              from the activeworkbook colour palette
  7. '              Then works through each cell in  the supplied range and
  8. '              determines the colorindex, and adds to array
  9. '              Finishes by returning acumulated array
  10. ' Variations:  Determines cell colour (interior) or text colour (font)
  11. '              Default is cell colour
  12. ' Constraints: Does not count colours set by conditional formatting
  13. '---------------------------------------------------------------------
  14. Function ColorIndex(rng As Range, _   Optional text As Boolean = False) As Variant
  15. '---------------------------------------------------------------------
  16. Dim cell As Range, row As Range
  17. Dim i As Long, j As Long
  18. Dim iWhite As Long, iBlack As Long
  19. Dim aryColours As Variant
  20.     If rng.Areas.Count > 1 Then
  21.         ColorIndex = CVErr(xlErrValue)
  22.         Exit Function
  23.     End If
  24.     iWhite = WhiteColorindex(rng.Worksheet.Parent)
  25.     iBlack = BlackColorindex(rng.Worksheet.Parent)
  26.     If rng.Cells.Count = 1 Then
  27.         If text Then
  28.             aryColours = DecodeColorIndex(rng, True, iBlack)
  29.         Else
  30.             aryColours = DecodeColorIndex(rng, False, iWhite)
  31.         End If
  32.     Else
  33.         aryColours = rng.Value
  34.         i = 0
  35.         For Each row In rng.Rows
  36.             i = i + 1
  37.             j = 0
  38.             For Each cell In row.Cells
  39.                 j = j + 1
  40.                 If text Then
  41.                     aryColours(i, j) = _
  42.                       DecodeColorIndex(cell, True, iBlack)
  43.                 Else
  44.                     aryColours(i, j) = _
  45.                       DecodeColorIndex(cell, False, iWhite)
  46.                 End If
  47.             Next cell
  48.         Next row
  49.     End If
  50.     ColorIndex = aryColours
  51. End Function
  52. '---------------------------------------------------------------------
  53. Private Function WhiteColorindex(oWB As Workbook)
  54. '---------------------------------------------------------------------
  55. Dim iPalette As Long
  56.     WhiteColorindex = 0
  57.     For iPalette = 1 To 56
  58.         If oWB.Colors(iPalette) = &HFFFFFF Then
  59.             WhiteColorindex = iPalette
  60.             Exit Function
  61.         End If
  62.     Next iPalette
  63. End Function
  64. '---------------------------------------------------------------------
  65. Private Function BlackColorindex(oWB As Workbook)
  66. '---------------------------------------------------------------------
  67. Dim iPalette As Long
  68.     BlackColorindex = 0
  69.     For iPalette = 1 To 56
  70.         If oWB.Colors(iPalette) = &H0 Then
  71.             BlackColorindex = iPalette
  72.             Exit Function
  73.         End If
  74.     Next iPalette
  75. End Function
  76. '---------------------------------------------------------------------
  77. Private Function DecodeColorIndex(rng As Range, _  text As Boolean, _    idx As Long)
  78. '---------------------------------------------------------------------
  79. Dim iColor As Long
  80.     If text Then
  81.         iColor = rng.Font.ColorIndex
  82.     Else
  83.         iColor = rng.Interior.ColorIndex
  84.     End If
  85.     If iColor < 0 Then
  86.         iColor = idx
  87.     End If
  88.     DecodeColorIndex = iColor
  89. End Function
  90. '---------------------------------------------------------------------
  91. ' End of ColorIndex Function
  92. '---------------------------------------------------------------------
½Æ»s¥N½X

cellcolor.rar (16.52 KB)
G¤j, §Ú¹ïmacro»yªk¯u¬O¦³­­¤½¥q, ¦ý¬O°ÝÃD§K±j¸Ñ¨M±o¨ì, ¤£¹L¥t¤@­Ó°ÝÃD¤S¨Ó...........

¬°¤°»ò excel ½d³ò·|¦³­­¨î
=SUMPRODUCT(--(ColorIndex(A1:A5462)=3))
½d³ò A1:A5461 ´N work
½d³ò A1:A5462 ©Î¥H¤W ´N¥Î¤£¨ì ( °ÝÃD¥X¦b¨º ?)

TOP

¦^´_ 3# jakcy1234
2003´ú¸Õ¨S³o°ÝÃD
¥iºë²¦p¤U
  1. Function MyColor(Rng As Range, MyIndex As Long) As Long
  2.     Dim A As Range, C As Range
  3.     For Each C In Rng.Cells
  4.         MyColor = MyColor + IIf(C.Interior.ColorIndex = MyIndex, 1, 0)
  5.     Next
  6. End Function
½Æ»s¥N½X
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

¦^´_ 4# GBKEE
  1. Sub PopulateRangeWithArray()
  2. Dim x
  3.    ReDim x(1 To 2, 1 To 2)
  4.    x(1, 1) = String(2000, "a"): x(1, 2) = String(5000, "b")
  5.    x(2, 1) = String(17000, "c"): x(2, 2) = String(33000, "d")
  6.    MsgBox Len(x(1, 1)) & "," & Len(x(1, 2)) _
  7.       & "," & Len(x(2, 1)) & "," & Len(x(2, 2))
  8.    Range("a1").Value = x(1, 1)
  9.    Range("b1").Value = x(1, 2)
  10.    Range("a2").Value = x(2, 1)
  11.    Range("b2").Value = x(2, 2)
  12. End Sub
½Æ»s¥N½X
§Ú¤w¸gª¾¹D °}¦C¤¤¤¸¯Àªº¼Æ¥Ø¤W­­¬O 5461, http://support.microsoft.com/kb/177991
¦ý¬O§Ú¤£ª¾¹D¥H¤W»y¥y«ç¼Ë­×§ï¤Î¥[´¡ cellcolor.rar (16.52 KB)

TOP

¥»©«³Ì«á¥Ñ GBKEE ©ó 2013-9-12 07:00 ½s¿è

¦^´_ 5# jakcy1234
³oºô­¶¬O«ü¨Çª©¥»  ªº°}¦C¤¤¤¸¯Àªº¼Æ¥Ø¤W­­¬O 5461  
     5.0                        A                B,C
   7.0 (Excel 95)             D                E,C,H
   8.0 (Excel 97)             F                G,H
   9.0 (Excel 2000)           F                G,H

¹Ï¥Ü :2003ª©ªº°õ¦æ¹Ï

  1. Sub ex()
  2.    Dim ar()
  3.     '2003ªºRows.Count=65536
  4.     ReDim ar(0 To Rows.Count + 1)
  5.     ar(Rows.Count + 1) = Rows.Count
  6.     MsgBox ar(Rows.Count + 1)
  7. End Sub
½Æ»s¥N½X
5# ªºµ{¦¡¬O±N¤@©w¼Æ¥Ø22000,5000,17000,33000 ªº¦r¦ê«ü©w¨ì°}¦C¦AÂà¦s¨ìÀx¦s®æ.
¥i±Nµ{¦¡½X½Æ»s¨ì¥ô¤@ªÅ¥Õ¤u§@ªí¼Ò²Õ ¸Õ¸Õ¬Ý  

4# ªº¦Û­q¨ç¼Æ  MyColor(Àx¦s®æ½d³ò , ¹Ï¼Ë©³¦â¼Æ¦r) ¸Õ¸Õ¬Ý
¥i¶Ç¦^: Àx¦s®æ½d³ò¹Ï¼Ë=¹Ï¼Ë©³¦â¼Æ¦rªº­Ó¼Æ
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

        ÀR«ä¦Û¦b : ¤p¨Æ¤£°µ¡B¤j¨ÆÃø¦¨¡C
ªð¦^¦Cªí ¤W¤@¥DÃD