誠求指點 Get Cell Color 公式 marco

jakcy1234

下載 (144.47 KB)

2013-9-10 13:51

getcellcolor.rar (2.54 KB)

下載次數: 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 設定或傳回要尋找之儲存格格式類型的搜尋準則。
   
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  ' 清除 FindFormat 設定要尋找之儲存格格式類型的搜尋準則。
    
23. End Sub

複製代碼

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. '---------------------------------------------------------------------

複製代碼

下載 (129.38 KB)

2013-9-11 08:35

cellcolor.rar (16.52 KB)

下載次數: 4

2013-9-11 08:36

G大, 我對macro語法真是有限公司, 但是問題免強解決得到, 不過另一個問題又來...........

為什麼 excel 範圍會有限制
=SUMPRODUCT(--(ColorIndex(A1:A5462)=3))
範圍 A1:A5461 就 work
範圍 A1:A5462 或以上 就用不到 ( 問題出在那 ?)

GBKEE

回復 3# jakcy1234
2003測試沒這問題
可精簡如下

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

複製代碼

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

複製代碼

我已經知道 陣列中元素的數目上限是 5461, http://support.microsoft.com/kb/177991
但是我不知道以上語句怎樣修改及加插 cellcolor.rar (16.52 KB)

下載次數: 3

2013-9-11 18:00

GBKEE

回復 5# jakcy1234
這網頁是指些版本  的陣列中元素的數目上限是 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版的執行圖

下載 (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

複製代碼

5# 的程式是將一定數目22000,5000,17000,33000 的字串指定到陣列再轉存到儲存格.
可將程式碼複製到任一空白工作表模組 試試看  

4# 的自訂函數  MyColor(儲存格範圍 , 圖樣底色數字) 試試看
可傳回: 儲存格範圍圖樣=圖樣底色數字的個數