VBAでセルを条件数う塗りつぶしたい

質問

特定のセル文字（記号）を入力すると、その横のセルに条件分の数セルを塗りつぶしたいです。
条件付き書式ではなんとかできたのですが、できればVBAでできればと思っています。

たとえば、◎なら右に3つ黄色に
△なら右に2つ青
○なら右に1ピンク
☆なら、表の端まで赤に。

すべて、表が終われば、塗りつぶしはなしにしたいです。

どうか、よろしくお願いします。

回答No.4

Wendy02 · ベストアンサー

>色が入った後のセルに再度文字を入力し、再度マクロを動かしても、色が消えないように…したかったです

#1の補足と、#2の補足とは意味が違いますね。

私の場合は、その部分自体は着目していたけれども、この言葉そのものを実現するには、意外に、難しいような気がします。

>記号の後ろに違う文字が入っても認識するには、どうすればいいか？できれば教えていただきますか？
というなら、こうなります、このほうが楽です。ただし、記号は、必ず、最初になくてはなりません。

Sub TestMacro1R()
　Dim rng As Range
　Set rng = Range("C3:G12")
　rng.Interior.ColorIndex = xlNone
　On Error Resume Next
　For Each c In rng
　　With c
　　If LTrim(.Value) Like "◎*" Then
　　　 Intersect(rng, .Offset(, 1).Resize(, 3)).Interior.ColorIndex = 6　 '黄色
　　ElseIf LTrim(c.Value) Like "△*" Then
　　　 Intersect(rng, .Offset(, 1).Resize(, 2)).Interior.ColorIndex = 33 'スカイブルー
　　ElseIf LTrim(c.Value) Like "○*" Then
　　　 Intersect(rng, .Offset(, 1).Resize(, 1)).Interior.ColorIndex = 40 'ベージュ
　　ElseIf LTrim(c.Value) Like "☆*" Then
　　　 Intersect(rng, .Offset(, 1).Resize(, 4)).Interior.ColorIndex = 3 '赤
　　End If
　　End With
　Next
　On Error GoTo 0
End Sub

お礼

補足が、説明不足で、違う意図になっていました。
すみません。

記号の横（後ろに続き）に補足事項を記入したセルも、記号のみのセルも塗りつぶしを行い、また塗りつぶし後のセルは、右横の列に記号が入力されても塗りつぶしが消えないようにしたいと、もっと詳しく質問するべきでした。

これで、やっていきます。
ありがとうございました。

回答No.3

keithin

こういう事ですかね？

Sub sample2()
　Dim h As Range
　Dim n, c

　For Each h In Range("C3:G" & Range("B65536").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)
　Select Case h.Value
　Case "○"
　　c = 7: n = 1
　Case "◎"
　　c = 6: n = 3
　Case "△"
　　c = 8: n = 2
　Case "☆"
　　c = 3: n = 99
　Case Else
　　n = -1
　End Select

　On Error Resume Next
　Application.Intersect(h.Offset(0, 1).Resize(1, n), Range("C:G")).Interior.ColorIndex = c
　On Error GoTo 0
　Next
End Sub

＞色が入った後のセルに再度文字を入力し、再度マクロを動かしても、色が消えないように…したかったです

そういった思いつきでダラダラ次々質問を投げられると，いつまでたっても終わらないです。

お礼

すみません。説明不足、言葉足らずでした。

列ごとにC列から入力して、１列入力が終わるとマクロを動かします。
なので、次の列に再度記号が入ったときにでも、今までの色が消えず、残っている状態にもっていきたかったということです。

言葉足らずの質問に対しても、お答えいただきありがとうございました。

回答No.2

Wendy02

こちらは、Excel 2003で作ったので、色は、Excel 2007のように行きませんので、Webサイトで見える色になるべく近づけました。色は、ご自身で書き換えてください。

例：
ピンク---7
青 ---5

'//
Sub TestMacro1()
　Dim rng As Range
　Set rng = Range("C3:G12")
　'一旦、全部を色を消す
　rng.Interior.ColorIndex = xlNone
　On Error Resume Next
　For Each c In rng
　　With c.Offset(, 1)
　　Select Case Trim(c.Value)
　　　Case "◎": Intersect(rng, .Resize(, 3)).Interior.ColorIndex = 6 '黄色
　　　Case "△": Intersect(rng, .Resize(, 2)).Interior.ColorIndex = 33 'スカイブルー
　　　Case "○": Intersect(rng, .Resize(, 1)).Interior.ColorIndex = 40 'ベージュ
　　　Case "☆": Intersect(rng, .Resize(, 4)).Interior.ColorIndex = 3 '赤
　　End Select
　　End With
　Next
　On Error GoTo 0
End Sub

補足

記号の後ろに違う文字が入っても認識するには、どうすればいいか？できれば教えていただきますか？

例：
☆A　　◎算数　など…

回答No.1

keithin

とりあえず一例：

Sub sample1()
　Dim h As Range
　Dim n, c

　For Each h In Range("C3:G" & Range("B65536").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)
　Select Case h.Value
　Case "○"
　　c = 7: n = 1
　Case "◎"
　　c = 6: n = 3
　Case "△"
　　c = 8: n = 2
　Case "☆"
　　c = 3: n = 99
　Case Else
　　n = -1
　End Select

　h.Interior.ColorIndex = xlNone
　On Error Resume Next
　Application.Intersect(h.Offset(0, 1).Resize(1, n), Range("C:G")).Interior.ColorIndex = c
　On Error GoTo 0
　Next
End Sub

たとえば色が入るべきセルに他の記号や他の記号による色のセルがかぶったらどうしたいのかとか，具体的にどんなタイミングでマクロを働かせたいのかとか，状況の想定が幾つか不明確です。実際に使いながらやりたいこと（ホントはこういう風にしたかった）を整理して，適宜応用してみてください。

お礼

早速の回答ありがとうございました。
助かりました。

補足

色が入った後のセルに再度文字を入力し、再度マクロを動かしても、色が消えないように…したかったです