エクセルVBA 条件にあうときセルを塗りつぶすには？

質問

エクセルVBA 条件にあうときセルを塗りつぶすには？

エクセルVBAについて教えてください。

_________A 列 _________B 列_________C列_________D列
--------------------------------------------
1行| 基準値_________ 5_____________1____________8
2行| りんご____________1_____________9____________０
3行| みかん___________12___________5____________3
4行| ぶどう____________15___________7____________8
5行| バナナ____________3_____________1____________4

上図のようにデータがあります。
（実物は列行共に膨大です。また条件を４つ以上つける予定なので条件付書式は使えません）

各列の基準値に対して、セルの増減が、０以下のときに黄色に、５から８のとき大きくなるときに赤、９以上のときに青にセルの色を塗りつぶしたいです。
どのようにすればよいでしょうか？

B列の場合、基準値が５です。
B2のセルの場合、基準値５と１（B2セル）の増減は－４です。
増減が０以下のときは黄色に、増減が５から８のときは赤に、増減が９以上のときに青にするので、このときは黄色に塗りつぶします。

B3のセルの場合、基準値５と１２（B３セル）の増減は７です。
増減が５から８のとき赤に塗りつぶすので、このセルは赤に塗りつぶします。

B4のセルの場合、基準値５と１５（B４セル）の増減は１０です。
増減が９以上のとき青色に塗りつぶすので、このセルは青色に塗りつぶします。

C２のセルの場合は、C列の基準値は１（C1セル）です。
基準値１と９（C2のセル）の増減は８です。
増減が５から８のとき赤に塗りつぶすので、このセルは赤に塗りつぶします。

よろしくお願いいたします。

回答No.12

hoiho11 · ベストアンサー

すみません　つまらないミスに気づきました

誤）For　Each　C　In　Range（Cells(2,1), Cells( Endclo , Endrow))

正）For　Each　C　In　Range（Cells(2,1), Cells( Endrow , Endcol))

これよく間違えてしまいます

Cells表記は左が行、右が列です

お礼

今日は外出していたので、お礼が遅くなって申し訳ございません。
昨日から大変お世話になり、本当にありがとうございました。
教えて頂いたコードで無事実行することができました。
今回VBAを教えて頂き、VBAを勉強してみようと思いました。
そして、早速VBAの本を買いました。
VBAの本を片手に自分なりにコードを一部変えてみました。

Private Sub SetColor1()

Dim i As Long
Dim Col As Integer
Dim atai As Integer
Dim area As String
Dim keyCells As String
Dim Endrow As Long

'基準値の行を指定
Col = 2
'基準値の下のセルを指定
area = "b3"

Endrow = Range(area).End(xlDown).Row

'塗りつぶし対象となる起点「d3」と塗りつぶし対象末の列「i」を指定
For Each c In Range("d3:i" & Endrow)

atai = c.Value - Cells(Col, c.Column)

If c.Value <> "" Then

Select Case atai

Case Is <= -1
c.Interior.ColorIndex = 6

Case 5 To 8
c.Interior.ColorIndex = 3

Case Is >= 9
c.Interior.ColorIndex = 5

End Select
End If
Next

End Sub

回答No.13

Wendy02

単に、範囲の取り方の問題が解決出来れば、それでできると思いますが……
以下の場合、A1が最初でないと、ちょっとややこしいことになりそうな気がします。

'//標準モジュールが良い
Sub Test1()
　Dim r As Range
　Dim i As Long, j As Long
　Dim ret As Double
　Set r = Range("A1").CurrentRegion
　Set r = r.Offset(, 1).Resize(, r.Columns.Count - 1)
　r.Interior.ColorIndex = xlColorIndexNone
　Application.ScreenUpdating = False
　With r
　　For j = 1 To r.Columns.Count
　　　For i = 2 To r.Rows.Count - 1
　　　　ret = .Cells(i, j).Value - .Cells(1, j).Value
　　　　If ret <= 0 Then
　　　　　.Cells(i, j).Interior.ColorIndex = 6
　　　　ElseIf ret > 4 And ret < 9 Then
　　　　　.Cells(i, j).Interior.ColorIndex = 3
　　　　ElseIf ret > 8 Then
　　　　　.Cells(i, j).Interior.ColorIndex = 5
　　　　End If
　　　Next i
　　Next j
　End With
　Application.ScreenUpdating = True
End Sub

回答No.11

hoiho11

更に、

エクセルの質問はこの掲示板では無理がありますね
インデントも反映されないし・・

http://www.officetanaka.net/

ここを使うのをお勧めします
この中に掲示板というのがあります
このサイトの利点は　質問したいエクセルブックを掲示板にアップロードできることです
説明が難解、　回答がなかなか理解できない
そのばあいに実際のブックをアップロードできるので
回答者も質問者の意図を理解しやすいのです

但し、アップロードするブックのプロパティを見て
個人情報（ユーザー名、会社名）は削除してからアップロードすること）

ワタシもここにお世話になっています

回答No.10

hoiho11

♯８の　For　Each　C　In　Range（”B2:" & Endclo & Endrow)

は間違いです　♯９のコードでやってください

ワタシは今　京橋のベろーチェでアイスコーヒーを飲みながら約束の時間まで
時間つぶしをしていますが何か？

回答No.9

hoiho11

基点セルは
For　Each　C　In　Range（Cells(2,1), Cells( Endclo , Endrow))
のcells(2,1)です　これは2列目の1行目　をあらわしています

Dim i As Long
Dim atai As Integer
Dim Endrow As Long
Dim EndCol As Integer
Endclo=Range("a1").End(xlToRight)
Endrow = Range("a2").End(xlDown).Row

For　Each　C　In　Range（Cells(2,1), Cells( Endclo , Endrow))

atai = c.Value - Cells(1, c.Column)

If c.Value <> "" Then

Select Case atai

Case Is <= 0

c.Interior.ColorIndex = 6

Case 5 To 8
c.Interior.ColorIndex = 3

Case Is >= 9
c.Interior.ColorIndex = 5

End Select
End If
Next

End Sub

回答No.8

hoiho11

＞また、行や列が追加されたときに、起点？（表の始まり）が変わるのです

行は最終行を自動で取得していますので何もしなくていいです
列は手動ですので
For　Each　C　In　Range（”B2:D" &Endrow)

このDを変更します

自動で取得する場合は

Dim EndCol As Integer

Endclo=Range("a1").End(xlToRight)

For　Each　C　In　Range（”B2:" & Endclo & Endrow)

にします
Endclo=Range("a1").End(xlToRight)は
Endrow = Range("a2").End(xlDown).Rowのすぐ下に書いてください

以上です　　これによって行も列の自動的に増えた分に対応します

なお基点は自動にはできません
B2のところを変えてください

回答No.7

hoiho11

追伸：

今回使ったコードは下記で構成されています

繰り返し処理　For　Each～
　これは指定範囲（今回はB2：D取得した最終行）の範囲のセルを
　１こずつ処理する方法です　”C”がそれにあたり今ここを見ています
　という情報がCに格納されます　

　Cが空白でなかったばあい～
　そのときのCの値、Cの列情報（Column）を取得して比較基本セルを指定します
　比較基本セルの行は固定ですがCは位置が変動するのでそのときの列を指定する
　必要があります　
　で、これを引き算した結果をAtaiに格納します

Select　Case～

　これは条件分岐処理です　
　ataiに格納された数値によって処理を分岐します

色塗りは説明しなくてもいいですよね
マクロの自動記録でも記録されますからそれから余分なものを排除すればいいのです

For　Each～は動作速度は比較的遅いですが理解しやすいでしょう
ワタシはこれをよく利用します
初心者域では動作スピードよりもコードを理解しやすいものを選んで使ったほうがいいです

回答No.6

hoiho11

>VBAを全く触ったことがない超初心者なので、ヒントを頂いても全く応用がききません。

ならばこれはきちんと書いたほうがよい！

あんまり時間が無いときに　さらっと書いたので細かいところはわかるだろうと
判断しました　まったくの初心者とは想像外でした
初心者ならばVBAなんて言葉すら知らないだろうし・・。

以上です

回答者は質問者の事情がわかりません
具体的に簡潔にそういう事情も書いたほうが早く目的にたどり着けます

質問の例（なにをしたいのか）は非常にわかりやすかったのは評価いたします。

補足

最初から最後まで頼りっぱなしで、本当に申し訳ないです。
サンプル例はD列までですが、AA列まであるときは、どこを変えればよいのでしょうか？

また、行や列が追加されたときに、起点？（表の始まり）が変わるのですが、そのときは、どこを変えればよいのでしょうか？

まことに申し訳ないのですが、ご回答いただければありがたいです。

回答No.5

hoiho11

これならよいですか？

Sub 色塗り()

Dim c As Range
Dim i As Long
Dim atai As Integer
Dim Endrow As Long

Endrow = Range("a2").End(xlDown).Row

For Each c In Range("b2:d" & Endrow)

atai = c.Value - Cells(1, c.Column)

If c.Value <> "" Then

Select Case atai

Case Is <= 0

c.Interior.ColorIndex = 6

Case 5 To 8
c.Interior.ColorIndex = 3

Case Is >= 9
c.Interior.ColorIndex = 5

End Select
End If
Next

End Sub

補足

ありがとうございます。
教えていただいた方法で、できそうです。
会社で試してみます。
本当に感謝します。

回答No.4

hoiho11

え”？

丸投げですか・？

空白も色が付くならば

If c.Offset(0, 1).Value <> "" Then
を追加してやればいいし
1行しか処理できないとあるけど
補足にも書いたように　同じようにフィールド番号を書きかえてコードを追加してやれば
いいんじゃないですか　そう書いたつもりだけど・・

少しは考えようよ。

補足

丸投げ・・・。そうですよね。本当に申し訳ないです。
VBAを全く触ったことがない超初心者なので、ヒントを頂いても全く応用がききません。
通常はエクセルの条件付書式で行うのですが、条件が４つ以上あるために、その機能も使えません。

教えていただいた下のコードで、B列は処理をできました。
For Each c In Range("a2:a" & Endrow)

atai = c.Offset(0, 1).Value - Range("b1").Value

If atai <= 0 Then
c.Offset(0, 1).Interior.ColorIndex = 6

End If

Next
このコードを参考にして、C列も考えてはいるものの、根本的なことがわかっていないため自分の力で実現できそうにありません。
もう少し、助けていただけないでしょうか？
よろしくお願いいたします。

回答No.3

hoiho11

補足：

c.Offset(0, 1).Interior.ColorIndex = 6

A列を基準にしてレコードがなくなるまで処理をします

A列基準からいくつずれているかを指定するのがOffsetであり
Offset(0,1)とは　A列の同じ行数の1個右のセルという意味です