Excelのマクロでセル内の数値によってセルの色分け

質問

はじめまして。マクロ初心者です。
よろしくお願いいたします。

エクセルに入力されている数値によってセルを色分けしたいのです。
数値はこんなふうに入力されています↓

A0＊22＊33＊44
　　　　　　　　　　　　　B1＊22＊33＊44
A2＊12＊55＊66　　　　　　　　　　　　　　　D1＊77＊22＊88
　　　　　　　　　　　　　C1＊12＊55＊66　　　　　　　　　　　　　　　E2＊99＊12＊11　

こういったものが全部で1500行ほどです。
＊は空白を表しています。
この中の、空白を入れて左から4つめの数字が2、5つめが2のときは赤、
左から4つめの数字が1、5つめの数字が2のときは青、
それ以外のときはそのまま…
といった具合に全部で5種類5色に色分けしたいのですが、どうにも能力が足りなくて困っています。
最初、自分なりにネット等参考にしながら「22という数値を含むセルは赤」といったように作ったのですが、
どうしても左から4文字目5文字目に限定しないと余計なセルにも色が付いてしまうのです。
もう2日も悩んでいますが、どうにも手も足も出ません。
ご指導いただけると本当に助かります。
どうぞよろしくお願いいたします。

回答No.3

Wendy02 · ベストアンサー

こんにちは。

>こういったものが全部で1500行ほどです。
>＊は空白を表しています。

間の空白が、半角であり、空白は1つであるという確約はないと思うのですね。
1500行で、数多くある場合は、そういうことを想定しないといけないような気がします。

私のコードの考え方は、空白で仕切られた4つの塊の文字列の2番目が、何であるかを検索しています。

確実に、その場所にあるというなら、
For Each c In rng で、
If Mid(c.Value, 4, 2) = 22 Then とすればよいです。

なお、色は、塗りつぶすなら、Interior の場合は、パステルカラー。Font なら、原色がよいです。

-----------------------------------------------
'Case のところに、数値と色を加えてください。

Sub TestMacro1()
　　Dim rng As Range
　　Dim c As Range
　　Dim buf As Variant

　　Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
　　Application.ScreenUpdating = False
　　rng.Interior.ColorIndex = xlNone
　　For Each c In rng.Cells
　　　　'全角スペースを半角にする
　　　　buf = Replace(Trim(c.Value), Space(1), Space(1), , , 1)
　　　　'スペースが2個以上入ったものをひとつにする
　　　　Do While InStr(1, buf, Space(2), 1) > 0
　　　　　buf = Replace(buf, Space(2), Space(1), , , vbTextCompare)
　　　　Loop
　　　　If UBound(Split(buf, Space(1))) > 0 Then
　　　　　　buf = Split(buf, Space(1))
　　　　　　'数値を探す(ここに入れる）
　　　　　　Select Case Val(buf(1))
　　　　　　　　Case 22: c.Interior.ColorIndex = 3 '赤(3), ローズ(38)-パステルカラー
　　　　　　　　Case 12: c.Interior.ColorIndex = 5 '青(5), 水色(34)-パステルカラー
　　　　　　End Select
　　　　End If
　　　　buf = Empty
　　Next c
　　Application.ScreenUpdating = True
End Sub

お礼

はじめまして。
ありがとうございます！

びっくりしました。すごいです。
空白が一つとは限らないですよね、確かに。
全角を半角にしたり、空白が二つ以上のときにひとつにしたり、
きめ細かい内容で本当に感謝します。
パステルカラーの件も、確かにおっしゃる通りです。
見る人への思いやりですね。
内容はまだまだ初心者の私には、見ても理解できないところがあるのですが、本を見ながら一つずつ理解してみます。
本当に助かりました。
どうもありがとうございました。

回答No.2

fumufumu_2006

こんなのではどうでしょうか？

データがあるのがSheet1だった場合です。
Sub sample()
Dim target As Range
Dim r As Range
Set target = Sheets("Sheet1").UsedRange
For Each r In target
If r <> "" Then
'とりあえず、色=自動の戻す
r.Font.ColorIndex = xlAutomatic
'空白を入れて左から4つめの数字が2、5つめが2のときは赤
If (Mid(r, 4, 1) = "2") And (Mid(r, 5, 1) = "2") Then
r.Font.ColorIndex = 3
End If
'左から4つめの数字が1、5つめの数字が2のときは青
If (Mid(r, 4, 1) = "1") And (Mid(r, 5, 1) = "2") Then
r.Font.ColorIndex = 5
End If
'必要に応じて条件を追加
End If
Next
End Sub

お礼

はじめまして。
ありがとうございます。
こうして書くのですね!!
本当に勉強になります。
これだと、4～5文字目のひとつが変わったときでも
簡単に変えられるのですね。
ありがとうございました。

回答No.1

nyankonosuke

１）現在作っているコードを貼り付けてもらえると、回答しやすいです。

２）質問文だけでは、５つの条件そのものがわからないので、５種類の条件をすべて教えてください。その際に５つの条件の優先順位も教えて下さい。

補足

はじめまして。

1)現在作っているコード↓

Sub Color()
Dim c
For Each c In Range("A1:E1500")
If InStr(c.Value,"12") > 0 Then
c.Interior.ColorIndex = 3
End If
Next c
End sub
こんな感じです。
本当に初心者なので、たどたどしいです。

2)5つの条件：すべて同じです。4～5文字目に限定するということ、
順番は特に関係なく、ただただ色分けができればいいというものです。
色も指示されていません。
4～5文字目は、12,22,30,44,60です。