Board logo

標題: 請問依儲存格數值條件顯示文字及背景色的問題 [打印本頁]

作者: yuch8663    時間: 2010-8-6 20:09     標題: 請問依儲存格數值條件顯示文字及背景色的問題

我寫了一段小程式主要是依據儲存格的值所屬的區間來產生顏色,但因為有不同的區間值分成好多區塊,每一區的大小不同,分級的數也不同
程式碼概略如下
Sub color()
'第一區----------------------------------------------------------------
    Dim Rng As Range, F As Variant
    For Each F In ThisWorkbook.Sheets("sheet2").[b4:i15]
        
        If F > 800 Then
           F.Interior.ColorIndex = 40
           F.Font.ColorIndex = 3
           F.Font.Bold = True
        ElseIf F > 500 And F <= 800 Then
           F.Interior.ColorIndex = 36
           F.Font.ColorIndex = 3
           F.Font.Bold = True
        ElseIf F > 200 And F <= 500 Then
           F.Interior.ColorIndex = 19
           F.Font.ColorIndex = 3
           F.Font.Bold = True
   
        ElseIf F < -200 And F >= -500 Then
           F.Interior.ColorIndex = 24
           F.Font.ColorIndex = 11
           F.Font.Bold = True
        ElseIf F < -500 And F >= -800 Then
           F.Interior.ColorIndex = 15
           F.Font.ColorIndex = 11
           F.Font.Bold = True
        ElseIf F < -800 Then
           F.Interior.ColorIndex = 48
           F.Font.ColorIndex = 11
           F.Font.Bold = True
        Else
         'F.Interior.ColorIndex = -4142 '無底色

           F.Interior.ColorIndex = 35 '
           F.Font.ColorIndex = 1
           F.Font.Bold = False
        End If
   Next
   
  For Each F In ThisWorkbook.Sheets("sheet2").[j4:l15]
        
        If F > 1600 Then
           F.Interior.ColorIndex = 40
           F.Font.ColorIndex = 3
           F.Font.Bold = True
        ElseIf F > 900 And F <= 1600 Then
           F.Interior.ColorIndex = 36
           F.Font.ColorIndex = 3
           F.Font.Bold = True
        ElseIf F > 400 And F <= 900 Then
           F.Interior.ColorIndex = 19
           F.Font.ColorIndex = 3
           F.Font.Bold = True
   
        ElseIf F < -400 And F >= -900 Then
           F.Interior.ColorIndex = 24
           F.Font.ColorIndex = 11
           F.Font.Bold = True
        ElseIf F < -900 And F >= -1600 Then
           F.Interior.ColorIndex = 15
           F.Font.ColorIndex = 11
           F.Font.Bold = True
        ElseIf F < -1600 Then
           F.Interior.ColorIndex = 48
           F.Font.ColorIndex = 11
           F.Font.Bold = True
        Else
         'F.Interior.ColorIndex = -4142 '無底色

           F.Interior.ColorIndex = 35 '
           F.Font.ColorIndex = 1
           F.Font.Bold = False
        End If
   Next
   ...........
後面還有,但都是重複的寫法,請問要如何縮短程式碼語法?[attach]2269[/attach]
作者: luhpro    時間: 2010-8-7 00:44

上述的情形可以利用 Switch 與 Choose 兩個函數來大幅簡化程式,
以下僅列出第一小段的程式,其餘僅需變更相關數字後再套用上去即可.

  Dim iRng%, F As Variant

  With ThisWorkbook.Sheets("sheet2")
    For Each F In .Range("b4:i15")
      iRng = Switch(F > 800, 1, F > 500 And F <= 800, 2, F > 200 And F <= 500, 3, F >= -200 And F <= 200, 4 _
         , F < -200 And F >= -500, 5, F < -500 And F >= -800, 6, F < -800, 7)
      F.Interior.ColorIndex = Choose(iRng, 40, 36, 19, 35, 24, 15, 48)
      F.Font.ColorIndex = Choose(iRng, 3, 3, 3, 1, 11, 11, 11)
      F.Font.Bold = Choose(iRng, True, True, True, False, True, True, True)
    Next

    For Each F In .Range("j4:l15")
    .
    .
    .
    Next

    .
    .
    .

  End With
作者: GBKEE    時間: 2010-8-7 07:29

回復 1# yuch8663
試試看
  1. Sub Color()
  2.    '示範到第三區----------------------------------------------------------------
  3.    Dim 區域 As Range, Ar1, Ar2, Ar3, 值, 底色, 字色, i%
  4.    Set 區域 = ThisWorkbook.Sheets("sheet2").[b4:i15,j4:l15,m4:n15]
  5.    '區域是各區的位置 請修改
  6.    Ar1 = Array(Array(800, 500, 200), Array(1600, 900, 400), Array(4000, 2500, 1000))
  7.    'Ar1 陣列 依序對應到是各區塊的值
  8.    Ar2 = Array(Array(40, 36, 19, 24, 15, 48, 35), Array(40, 36, 19, 24, 15, 48, 35), Array(3, 22, 40, 43, 50, 10, 39))
  9.    'Ar2 陣列 依序對應到是各區塊 If 所判斷的底色的索引值
  10.    Ar3 = Array(Array(3, 11, 1), Array(3, 11, 1), Array(6, 3, 1))
  11.    'Ar3 陣列 依序對應到是各區塊 If 所判斷的字體顏色的索引值
  12.     For i = 0 To 區域.Areas.Count - 1   '依序在 區域的各區塊
  13.         For Each F In 區域.Areas(i + 1).Cells  '依序在 區塊的每一個 Cell
  14.             值 = Ar1(i): 底色 = Ar2(i): 字色 = Ar3(i)   '取得區塊所對應到的陣列
  15.             F.Font.Bold = True
  16.             If F > 值(0) Then
  17.                 F.Interior.ColorIndex = 底色(0)
  18.                 F.Font.ColorIndex = 字色(0)
  19.             ElseIf F > 值(1) And F <= 值(0) Then
  20.                 F.Interior.ColorIndex = 底色(1)
  21.                 F.Font.ColorIndex = 字色(0)
  22.             ElseIf F > 值(2) And F <= 值(1) Then
  23.                 F.Interior.ColorIndex = 底色(2)
  24.                 F.Font.ColorIndex = 字色(0)
  25.             ElseIf F < -值(2) And F >= -值(1) Then
  26.                 F.Interior.ColorIndex = 底色(3)
  27.                 F.Font.ColorIndex = 字色(1)
  28.             ElseIf F < -值(1) And F >= -值(0) Then
  29.                 F.Interior.ColorIndex = 底色(4)
  30.                 F.Font.ColorIndex = 字色(1)
  31.             ElseIf F < -值(0) Then
  32.                 F.Interior.ColorIndex = 底色(5)
  33.                 F.Font.ColorIndex = 字色(1)
  34.             Else
  35.                 F.Interior.ColorIndex = 底色(6)
  36.                 F.Font.ColorIndex = 字色(2)
  37.                 F.Font.Bold = False
  38.             End If
  39.         Next
  40.     Next
  41. End Sub
複製代碼

作者: yuch8663    時間: 2010-8-9 10:16

謝謝GBKEE 版主指導,這個迴圈的寫法很高竿,對我來說有點難理解,我試著揣摩揣摩,謝謝。
作者: yuch8663    時間: 2010-8-9 10:43

剛剛沒注意看luhpro樓主的回覆luhpro 樓主的寫法似乎我比較容易理解,謝謝。
作者: yuch8663    時間: 2010-8-9 11:26

回復 5# yuch8663
請問luhpro 樓主,我參研擬的做法將分類標準更改為另一個區塊做參照,會在下列紅字區出現錯誤,請問是何原因?

Sub Color2() 'luhpro 樓主指導
'上述的情形可以利用 Switch 與 Choose 兩個函數來大幅簡化程式,'
'以下僅列出第一小段的程式,其餘僅需變更相關數字後再套用上去即可.

  Dim iRng%, F As Variant

  With ThisWorkbook.Sheets("sheet3")
    For Each F In .Range("b35:p46")
      iRng = Switch(F >= 0.06, 1, F >= 0.04 And F < 0.06, 2, F >= 0.02 And F < 0.04, 3, _
      F > 0 And F < 0.02, 4, F = 0, 5, F < 0 And F > -0.02, 6, _
         , F <= -0.02 And F > -0.04, 7, F <= -0.04 And F > -0.06, 8, F <= -0.06, 9)
      F.Offset(-30, 0).Interior.ColorIndex = Choose(iRng, 3, 46, 22, 40, -4142, 15, 43, 50, 10)
      F.Offset(-30, 0).Font.ColorIndex = Choose(iRng, 2, 2, 2, 1, 1, 1, 44, 44, 44)
      F.Offset(-30, 0).Font.Bold = Choose(iRng, True, True, True, False, False, False, True, True, True)
    Next '
  End With

End Sub

[attach]2306[/attach]
作者: GBKEE    時間: 2010-8-9 14:07

回復 6# yuch8663

Excel的說明
Switch 函數的引數串列包含多對的運算式和數值,運算式是由左至右加以計算,而數值則會在相聯的運算式為 True 時傳回。如果其中有部份沒有成對,則會產生一個執行中錯誤。如果 expr-1 為 True 則 Switch 傳回 value-1 ,如果 expr-1 為 False,但 expr-2 為 True,則 Switch 傳回 value-2 ,以此類推。
Switch 會傳回一個 Null 值,如果:
沒有一個運算式為 True.
第一個為 True 的運算式,其相對應得值為 Null。
Switch 會計算所有的運算式,雖然它只會傳回其中的一個值,因此您應該留意所產生的副作用,例如,有某個運算式會導致除以零,那麼就會發生錯誤。

作者: yuch8663    時間: 2010-8-9 15:22

謝謝GBKEE版主的解說,但是我不太了解,所謂的運算式是指,F >= 0.06中的"大於"、"等於"、"小於"這些嗎?我檢查過這九組分組並沒有重疊的部分,為何還是有誤?我試過luhpro 樓主的方式在原範例中是可以運行的
魏何增加了二組判斷就不行?
作者: GBKEE    時間: 2010-8-9 16:50

回復 8# yuch8663
公式太長會看到眼花 多出一個 ,
   iRng = Switch(F >= 0.06, 1, F >= 0.04 And F < 0.06, 2, F >= 0.02 And F < 0.04, 3, _
      F > 0 And F < 0.02, 4, F = 0, 5, F < 0 And F > -0.02, 6, _
        , F <= -0.02 And F > -0.04, 7, F <= -0.04 And F > -0.06, 8, F <= -0.06, 9)

   

作者: Min    時間: 2010-8-9 21:27

模組化呢 試試看!

Function SetCellInfo(ByVal fCell As Variant, ByVal iColorIndex As Integer, ByVal fColorIndex As Integer, ByVal fBold As Boolean)
    fCell.Interior.ColorIndex = iColorIndex '
    fCell.Font.ColorIndex = fColorIndex
    fCell.Font.Bold = fBold
End Function

    'Dim Rng As Range 這個變數是多餘的!
    Dim F As Variant
   
    For Each F In ThisWorkbook.Sheets("sheet2").[b4:i15]
        If F > 800 Then
            Call SetCellInfo(F, 40, 3, True)
        ElseIf F > 500 And F <= 800 Then
            Call SetCellInfo(F, 36, 3, True)
        ElseIf F > 200 And F <= 500 Then
            Call SetCellInfo(F, 19, 3, True)
        ElseIf F < -200 And F >= -500 Then
            Call SetCellInfo(F, 24, 11, True)
        ElseIf F < -500 And F >= -800 Then
            Call SetCellInfo(F, 15, 11, True)
        ElseIf F < -800 Then
            Call SetCellInfo(F, 48, 11, True)
        Else
            Call SetCellInfo(F, 35, 1, False)
        End If
    Next F
作者: yuch8663    時間: 2010-8-9 22:04

GBKEE版主感恩哪,我還真沒看出那一點,若不是切割程式行自己應該可以發現的到。
閔版主的模組化設計也是堪稱一流,不過我不太容易理解,還不曉得該如何套用,但是都很感恩各位版主的指導,謝謝。
作者: Min    時間: 2010-8-10 13:16

GBKEE版主感恩哪,我還真沒看出那一點,若不是切割程式行自己應該可以發現的到。
閔版主的模組化設計也是堪 ...
yuch8663 發表於 2010/8/9 10:04 PM


您可以用F8逐步跑跑看 有問題再上來問~




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)