| |
シートで色付け範囲の位置が違うなら修正が必要ですが・・
位置が同じで同条件なら
For Each rng In Range("色付範囲01")
を
For Each rng In Range("b10").Resize(10, 10)
For Each rng In Range(Range("b10"), Range("b10").Offset(10, 10))
For Each rng In Range("b10:k19")
などと直接に指定するといいです。
あと↑コードだとかなり長くなるのでしきい値を配列で持つと
Sub 色付け1()
Dim rlimen 'しきい値(最小値,（9個のしきい値）,最大値)
rlimen = Array(1, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100)
Call 色付け2(rlimen, Range("b10")) 'b10から10*10範囲
rlimen = Array(10, 21, 35, 50, 65, 70, 85, 100, 115, 130, 150)
Call 色付け2(rlimen, Range("b25"))
rlimen = Array(50, 61, 75, 90, 105, 120, 135, 150, 165, 180, 200)
Call 色付け2(rlimen, Range("b40"))
rlimen = Array(80, 100, 123, 145, 167, 199, 221, 243, 265, 287, 300)
Call 色付け2(rlimen, Range("b55"))
End Sub
Private Sub 色付け2(rlimen, clrange As Range)
Dim rng As Range
Dim rcolor()
rcolor = Array(RGB(211, 255, 255), RGB(178, 255, 255), RGB(204, 255, 204), RGB(75, 255, 75), _
RGB(255, 255, 153), RGB(255, 255, 0), RGB(255, 204, 0), _
RGB(255, 153, 0), RGB(255, 102, 0), RGB(255, 0, 0))
For Each rng In clrange.Resize(10, 10)
Select Case rng.Value
Case rlimen(0) To rlimen(1) - 1
rng.Interior.Color = rcolor(0)
Case rlimen(1) To rlimen(2) - 1
rng.Interior.Color = rcolor(1)
Case rlimen(2) To rlimen(3) - 1
rng.Interior.Color = rcolor(2)
Case rlimen(3) To rlimen(4) - 1
rng.Interior.Color = rcolor(3)
Case rlimen(4) To rlimen(5) - 1
rng.Interior.Color = rcolor(4)
Case rlimen(5) To rlimen(6) - 1
rng.Interior.Color = rcolor(5)
Case rlimen(6) To rlimen(7) - 1
rng.Interior.Color = rcolor(6)
Case rlimen(7) To rlimen(8) - 1
rng.Interior.Color = rcolor(7)
Case rlimen(8) To rlimen(9) - 1
rng.Interior.Color = rcolor(8)
Case rlimen(9) To rlimen(10)
rng.Interior.Color = rcolor(9)
Case Else
rng.Interior.Color = RGB(255, 255, 255)
End Select
Next
End Sub
こんな感じでだいぶスッキリします。
しきい値が（最大値-最小値）/10ならさらに短くなりますが・・・
|
|
［名前なし］
- 13/12/11(水) 18:19 -
