エクセルVBAでデータ中の文字列セルに色をつけたい

質問

下記のようなデータがあり、●、■文字のセルに色をつけたいです。●、■以外の何種類かの文字列にも各々の色をつけます。ここでは２種類にします。
データ中にはランダムに空白があります。空白には何も入れないで色つけをしたいです。

ABCDEFGHIJKLMN・・・
1■●○○●○■○・・・
2○　○■○■○●・・・
3■○　　　●○　・・・
4●○　■○　○■・・・
5○　●○○　●■・・・
・・・・・・・・・・・・・・・・
・・・・・・・・・・・・・・・・

I

回答No.1

merlionXX · ベストアンサー

こんな感じでしょうか？

Sub test()
Dim c As Range
For Each c In ActiveSheet.UsedRange
Select Case c.Value
Case "●"
c.Interior.ColorIndex = 3
Case "■"
c.Interior.ColorIndex = 6
End Select
Next
End Sub

お礼

ありがとうございました。
シンプルなコードでこれなら追加が簡単です。助かりました。

回答No.2

Wendy02

こんにちは。

＞下記のようなデータがあり、●、■文字のセルに色をつけたいです。●、■以外の何種類かの文字列にも各々の色をつけます。ここでは２種類にします。
それは、以下のコードで出来ます。

＞空白には何も入れないで色つけをしたいです。
しかし、パターンの色付けということですか？
別のコードにするしかないかもしれませんね。

'<標準モジュール>
Sub Sample1()
　 Dim myWords As Variant, myColors As Variant
　 Dim myFadd As String, c As Range, i As Long
　 '=========================================
　 'ユーザー設定部分（[,]コンマで切ること）
　 Const 検索値 As String = "●,■"
　 Const 色番号 As String = "3,5" ' 赤と青　'色番号は下記参照
　 '=========================================
　 myWords = Split(検索値, ",")
　 myColors = Split(色番号, ",")
　 If UBound(myWords) <> UBound(myColors) Then MsgBox "検索値と色の数は合わせてください。", 64: Exit Sub
　 For i = LBound(myWords) To UBound(myWords)
　　　Set c = Cells.Find(What:=myWords(i), LookIn:=xlValues, LookAt:=xlWhole)
　　　If Not c Is Nothing Then
　　　　 myFadd = c.Address
　　　　 Do
　　　　　　c.Font.ColorIndex = myColors(i)
　　　　　　Set c = Cells.FindNext(c)
　　　　 Loop Until c Is Nothing Or c.Address = myFadd
　　End If
　Next
　'Call Sample2　　　''ここを外せば、Sample2 に進みます。
End Sub

Sub Sample2()
Const 色番号 As String = 8　'水色
　On Error Resume Next
　 Cells.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 色番号
　On Error GoTo 0
End Sub

代表的な、ColorIndex（色番号）です。
'黒(1),白(2),赤(3),黄緑(4),青(5),黄色(6),ピンク(7),
'水色 (8), 茶(9), 緑(10), 藍(11), 黄土色(12), 紫(13), 濃緑(14)
'灰色 (15), 濃い灰色(16),淡い水色(34),ゴールド(44),オレンジ(45),
'黄緑 (35)

お礼

ありがとうございます。
＞空白には何も入れないで色つけをしたいです。
空白は空白のままで、という意味でした。わかりにくい表現でしたね（^^;