EXCEL VBA で複数の特定文字に色をつけたい

マクロ実行で以下のように一括色変更できないでしょうか？
１文字での変更は下記コードでおこなうことができましたが、複数であると初心者でとても分かりません。
※S25とＦ３０．、Ｆ５．は加工進行でいろいろ数値のみ変えます。
※Ｍ１００、Ｍ１０１は全体の４文字は変わりませんが数字は増えていき、ランダムにこの先の加工進行上でてきます。
※Ｍ03、Ｍ００は３文字で変わりません。

現在以下のコードで1文字ずつならできます。


Sub test01()
Dim cl As Range
For Each cl In Range("a1:a10")
r = InStr(cl, "M00")
If r <> 0 Then
cl.Characters(r, 3).Font.ColorIndex = 3
End If
Next
End Sub

No.5 ベストアンサー 回答者： tom04 回答日時： 2013/07/19 18:05

No.2・3・4です！

親の仇のように顔をだします。

No.4のお礼欄に
＞Ｄ列、Ｅ列、Ｆ列、Ｇ列まで色を配置して
とありましたので・・・
列で色を決めるのではなく、前回のC列データのフォントを好みの色にしておいて
その文字はその色に表示する！という考え方でのコードにしてみました。
※　今回は複数回出現してもC列にあるデータはすべてをC列データ色にするようにしています。

Sub Sample2()
Dim i As Long, k As Long, n As Long, str As String
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To Cells(Rows.Count, "C").End(xlUp).Row
For n = 1 To Len(Cells(i, "A"))
str = Cells(k, "C")
If Mid(Cells(i, "A"), n, Len(str)) = str Then
Cells(i, "A").Characters(Start:=n, Length:=Len(str)).Font.Color = Cells(k, "C").Font.Color
End If
Next n
Next k
Next i
End Su

こんなんではどうでしょうか？m（_ _）m

この回答へのお礼

本当にありがとうございました。
さっそく吟味したいと思います。
また質問のときは、親の仇のように現れてください。

お礼日時：2013/07/19 20:36

No.4 回答者： tom04 回答日時： 2013/07/19 17:13

No.2・3です！

たびたびごめんなさい。

前回の方法はA列セルにC列データが1回しか出現しない！という前提ですので、
複数回出現し、すべてに色を付けたい場合は
A列の文字を舐めるように検索していく必要があると思います。

※　余計なお世話かもしれませんが、投稿後に気になったもので・・・

どうも失礼しました。m（_ _）m

この回答へのお礼

丁寧な解答ありがとうございます。
このコードも大変役に立つと感じました。
さらにＤ列、Ｅ列、Ｆ列、Ｇ列まで色を配置して列による
文字の色管理ができれば完璧です。
初心者ですので前回のコードも含めて最後までのコードが
知りたいです。

お礼日時：2013/07/19 17:44

No.3 回答者： tom04 回答日時： 2013/07/19 17:01

No.2です！

画像をアップするのを忘れていました。

何度もごめんなさい。m（_ _）m

No.2 回答者： tom04 回答日時： 2013/07/19 17:00

こんにちは！

一例です。

↓の画像のように別列（今回はC列）に色をつけたいデータを入力しておきます（空白セルがないように！）

データはA列の1行目からあるとします。

Sub Sample1()
Dim i As Long, k As Long
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To Cells(Rows.Count, "C").End(xlUp).Row
If InStr(Cells(i, "A"), Cells(k, "C")) > 0 Then
Cells(i, "A").Characters(Start:=InStr(Cells(i, "A"), Cells(k, "C")), Length:=Len(Cells(k, "C"))). _
Font.ColorIndex = 3
End If
Next k
Next i
End Sub

こんな感じではどうでしょうか？m（_ _）m

No.1 回答者： MSZ006 回答日時： 2013/07/19 16:24

S25とF30.とF5.において、数字部分の桁数が変化しないのでしたら、

Sub test01()
Dim cl As Range

For Each cl In Range("a1:a10")

r = InStr(cl, "M00")
If r <> 0 Then
cl.Characters(r, 3).Font.ColorIndex = 3
End If

r = InStr(cl, "M03")
If r <> 0 Then
cl.Characters(r, 3).Font.ColorIndex = 4
End If

r = InStr(cl, "M")
If r <> 0 And (cl Like "*M[0-9][0-9][0-9]*") Then
cl.Characters(r, 4).Font.ColorIndex = 5
End If

r = InStr(cl, "S")
If r <> 0 And (cl Like "*S[0-9][0-9]*") Then
cl.Characters(r, 3).Font.ColorIndex = 6
End If

r = InStr(cl, "F")
If r <> 0 And (cl Like "*F[0-9][0-9].*") Then
cl.Characters(r, 4).Font.ColorIndex = 7
End If

r = InStr(cl, "F")
If r <> 0 And (cl Like "*F[0-9].*") Then
cl.Characters(r, 3).Font.ColorIndex = 9
End If

Next
End Sub


という感じでどうでしょうか。

この回答へのお礼

早速やってみまして出来ました。！！こんなにうまくいくなんて！MSZ006 さん　ありがとうございました。今まで一つ一つ目で追ってやっていたが時間の無駄に感じています。

お礼日時：2013/07/19 17:12