フォントの色を保持したままセルの一部の置換

セルの一部を置換し、かつフォントの色を保持するマクロをご存知の方がいましたら教えてください。

例えば、
一つのセルに「123ABC」と入力されていて、「123」は赤、「ABC」は黒とします。ここで「123」を「1234」と置換した場合、「1234ABC」が全て赤となってしまい、困っています。「1234」を赤、「ABC」を黒としたいのです。

膨大な量を置換する必要があるため、できればマクロを使って解決したいと思っています。
どうか宜しくお願いします。

No.1 回答者： Sinogi 回答日時： 2009/07/18 19:43

たとえばセルA2の５文字目から４文字を赤にするコードはつぎでできます。

Cells(2, 1).Characters(Start:=5, Length:=4).Font.Color = RGB(255, 0, 0)

対象文字列のセル内での位置を取得して指定変更する

でいかが？

この回答への補足

すいません。マクロについては初心者でして、できればどのようにコードを組み合わせるべきかも教えていただけないでしょうか。

具体的にやりたいことは、
「△△(←黒)AW-2-1-○○(←赤) ××(←黒)」
↓
「△△(←黒)AW-2-S-1-○○(←赤) ××(←黒)」

というように、「S-」を挿入したい場所が「2-」と「1-」の間であることは固定なんですが、△や○や×は文字数も内容もセルによってことなる感じです。フォントの色を変えずに置換をかけるようなマクロはやはり難しいのでしょうか…

補足日時：2009/07/18 20:13

No.2 回答者： mitarashi 回答日時： 2009/07/19 10:38

一旦黒に戻したあと、置換後の文字列をパターンマッチングで切り分けて、赤に設定するのはどうでしょうか。

○、△、×の実際が分かりませんので、下記がそのまま通用するかどうかは分かりませんが。
詳細は「VBA 正規表現」で検索してください。複雑な事をしているので、処理時間はそれなりにかかります。
Sub test()
Dim i As Long
Dim targetString As String
Dim startPos As Long, myLength As Long
Dim myCell As Range

Set myCell = Range("A1")
myCell.Font.ColorIndex = 0　'一旦すべて黒に戻す
targetString = searchWord(myCell.Value, "[A-Z]{2}-\d-[A-Z]-\d-")
If targetString = "" Then Exit Sub
startPos = InStr(myCell.Value, targetString)
myCell.Characters(Start:=startPos, Length:=(Len(targetString) + 2)).Font.ColorIndex = 3
End Sub

Private Function searchWord(targetString As String, matchString As String) As String
Dim regEx As Variant, Matches As Variant, match As Variant

Set regEx = CreateObject("VBScript.RegExp")
regEx.MultiLine = False
regEx.Pattern = matchString
regEx.IgnoreCase = False
regEx.Global = False '一個見つかったら終了
Set Matches = regEx.Execute(targetString)
If Matches.Count > 0 Then
searchWord = Matches.Item(0)
Else
searchWord = ""
End If
Set Matches = Nothing
Set regEx = Nothing
End Function

No.3 回答者： imogasi 回答日時： 2009/07/20 15:06

検索のプログラムがうるさいだけで、後はCharacters関数を使うだけ。

コードの最初のWEBの記事は参考までに挙げます。
Sub Macro1()
'http://park7.wakwak.com/~efc21/cgi-bin/exqaloung …
Dim fc As Range
Dim fd As Range
Dim frst As String
Dim i
i = 1
Range("A1").Activate
Set fc = Range("A1:F30").Find(What:="1234", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False)
If fc Is Nothing Then
Else
frst = fc.Address
'MsgBox "第" & i & frst
p = InStr(fc.Value, "1234")
fc.Characters(Start:=p, Length:=4).Font.ColorIndex = 3

i = i + 1
fc.Next.Activate
End If
Do
Set fd = Range("A1:F30").FindNext(After:=ActiveCell)

'MsgBox "第" & i & fd.Address
p = InStr(fd.Value, "1234")
fd.Characters(Start:=p, Length:=4).Font.ColorIndex = 3
i = i + 1
'MsgBox frst
fd.Next.Activate
Loop While fd.Address <> frst
End Sub
("A1:F30"の辺りや1234は修正のこと。
見つからない場合の対処が甘いかも。補充してください。
元の字の色は変えないことをテスト済み。