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

jakcy1234

¤U¸ü (144.47 KB)

2013-9-10 13:51

getcellcolor.rar (2.54 KB)

¤U¸ü¦¸¼Æ: 7

2013-9-10 13:52

GBKEE

¦^´_ 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

jakcy1234

¦^´_ 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

¤U¸ü (129.38 KB)

2013-9-11 08:35

cellcolor.rar (16.52 KB)

¤U¸ü¦¸¼Æ: 4

2013-9-11 08:36

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¨º ?)

GBKEE

¦^´_ 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

jakcy1234

¦^´_ 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)

¤U¸ü¦¸¼Æ: 3

2013-9-11 18:00

GBKEE

¦^´_ 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ª©ªº°õ¦æ¹Ï

¤U¸ü (20.99 KB)

2013-9-11 20:23

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ªº­Ó¼Æ