返回列表 上一主題 發帖

誠求指點 Get Cell Color 公式 marco

jakcy1234

帖子
37 
主題
10 
精華
0 
積分
63 
點名
0  
作業系統
XP 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2013-8-25 
最後登錄
2016-5-24 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-9-10 14:03 | 顯示全部帖子

誠求指點 Get Cell Color 公式 marco



getcellcolor.rar (2.54 KB)
收藏 分享

jakcy1234

帖子
37 
主題
10 
精華
0 
積分
63 
點名
0  
作業系統
XP 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2013-8-25 
最後登錄
2016-5-24 
2#
發表於 2013-9-11 08:42 | 顯示全部帖子
回復 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. '---------------------------------------------------------------------
複製代碼

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

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

TOP

jakcy1234

帖子
37 
主題
10 
精華
0 
積分
63 
點名
0  
作業系統
XP 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2013-8-25 
最後登錄
2016-5-24 
3#
發表於 2013-9-11 18:02 | 顯示全部帖子
回復 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)

TOP

        靜思自在 : 多做多得。少做多失。
返回列表 上一主題