Excel2010 セル内の文字色を一部だけ変更するVBA

Excel2010を使用しています。

アクティブセルには、英文が入力されています。
例文を以下に２つ書きますが、()で囲まれた部分のフォントが赤色とご理解ください。
その他の部分のフォントは黒色です。

例文1
　If I (had) enough money,I (would) buy this book.

例文2
　(Had I known) it was an important document, I (would not have thrown) it away.


フォントが赤色の部分だけ、白色に変更したいと思い、モジュールシートに以下のように書きました。
例文１では問題ありませんが、例文2のように1文字目のフォント色が赤の場合、2文字目が勝手に黒に変更されてしまいます。

Sub mojiiro()

Dim i As Integer

For i = 1 To Len(ActiveCell)
If ActiveCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 3 Then
ActiveCell.Characters(Start:=i, Length:=1).Font.ColorIndex = 2
End If
Next i

End Sub

修正すべき部分を教えていただけないでしょうか。
何卒宜しくお願い致します。

No.1 ベストアンサー 回答者： tom04 回答日時： 2015/09/26 21:26

こんばんは！

確かに1文字目からフォント色が「赤」の場合は質問通りの動きになってしまいますね。
（いままで全く気づきませんでした。）

苦肉の策ですが、1文字ずつではなく
「赤」のフォント色の文字数を取得し、その文字数分だけフォント色を変える方法はどうでしょうか？

Sub Sample1()
Dim i As Long, cnt As Long, c As Range
If Selection.Count = 1 Then
Set c = Selection
For i = 1 To Len(c)
cnt = 0
If c.Characters(Start:=i, Length:=1).Font.ColorIndex = 3 Then
Do
If c.Characters(Start:=i + cnt, Length:=1).Font.ColorIndex <> 3 Or _
i + cnt > Len(c) Then Exit Do
cnt = cnt + 1
Loop
c.Characters(Start:=i, Length:=cnt).Font.ColorIndex = 2
End If
i = i + cnt
Next i
Else
MsgBox "1セルのみ選択してください"
End If
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

ありがとうございます！
早速試してみました。

以下のような、文頭と文末のフォント色が「赤」になっている場合、文末の処理ができず、苦しんでおりました。
(Will) we be in time for the plane if we leave now? No,you (won't.)

でも...マクロを2回実行するとうまくいきます。不思議です(+_+)
ですから、正しい処理を書いてくださっていることと思います。ありがとうございます。

文末のピリオドのフォント色は、必ず黒色とすることにしました。
少々納得は行かないのですが、とりあえず今日は、これで乗り切ろうと思います。

1つ質問ですが

c.Characters(Start:=i, Length:=cnt).Font.ColorIndex = 2
End If
i = i + cnt
Next i

の部分を

c.Characters(Start:=i, Length:=cnt).Font.ColorIndex = 2
i = i + cnt-1
End If
Next i

とするのは間違いでしょうか？

お礼日時：2015/09/27 01:16

No.5 回答者： tom04 回答日時： 2015/09/27 17:51

No.1です。

c.Characters(Start:=i, Length:=cnt).Font.ColorIndex = 2
i = i + cnt-1
End If
Next i

とするのは間違いでしょうか？

についてですが、
別に間違いというコトはないと思います。
おそらくそのコードでも動くはずです。
「-1」とするコトで一文字後戻りして、次のループになりますので、
すでに「白」に変わっている文字も、もう一度ループするのではないでしょうか？
今回は1セルだけですので、大勢に影響はないと思います。

とりあえずはこの程度で・・・m(_ _)m

この回答へのお礼

ありがとうございました<(_ _)>
心より感謝を申し上げます。

お礼日時：2015/09/27 17:56

No.4 回答者： 30246kiku 回答日時： 2015/09/27 12:42

＃２です

ごめんなさい
2007 でできたので回答してました
2010 特有の動きなのでしょうか

失礼しました

この回答へのお礼

とんでもないです！
大変勉強になりました。心より感謝しております<(_ _)>
いつか30246kikuさんのように、美しいモジュールを書けるようになりたいです！
私は2003から2010にしたので、2007では動作確認できないのですが、とにかく色々と変わっていてとまどいます。
本当にお世話になりました。ありがとうございました。

お礼日時：2015/09/27 16:28

No.3 回答者： bonaron 回答日時： 2015/09/27 05:31

先頭が赤の場合、連続した赤の部分を１動作で設定しないとまずいようですね。

さもないとデータそのものも乱れて表示されたりします。（2007 sp2)

最初の赤だけ特別扱い、あとは普通に１文字ずつで大丈夫です。

Sub mojiiro()
　　Dim i As Long
　　Dim cnt As Long

　　With ActiveCell
　　　　For i = 1 To Len(ActiveCell)
　　　　　　If .Characters(i, 1).Font.ColorIndex = 3 Then
　　　　　　　　cnt = cnt + 1
　　　　　　Else
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i

　　　　If cnt > 0 Then
　　　　　　.Characters(1, cnt).Font.ColorIndex = 2
　　　　End If

　　　　For i = cnt + 1 To Len(ActiveCell)
　　　　　　If .Characters(i, 1).Font.ColorIndex = 3 Then
　　　　　　　　.Characters(i, 1).Font.ColorIndex = 2
　　　　　　End If
　　　　Next i
　　End With
End Sub

この回答へのお礼

ありがとうございます！
他の方にも書いたのですが、
(Will) we be in time for the plane if we leave now? No,you (won't.)
のように文末のフォント色を変えようとした場合に、うまく動作しません。

bonaronさんのマクロを加工して、連続した部分の文字色を変更したり、一文字ずつ変更したりしているうちにデータが乱れ、数式バーの内容とセルの内容が異なる現象もおきました。
最後にはファイルが壊れます・・・。なんでしょうね・・・。

bonaronさんの書いてくださったとおり、文頭の文字は特別扱いが必要なように、文末も特別扱いが必要なのかもしれません。

文末のピリオドを黒色に変更した後、マクロを実行すれば問題ありません。
疑問が残ってしまいましたが、仕事を進める上では全く支障ないので、今回はありがたくこれで進めようと思います。

貴重なお時間を割いていただき、本当にありがとうございました。

お礼日時：2015/09/27 12:22

No.2 回答者： 30246kiku 回答日時： 2015/09/27 04:01

大差ありませんが、雰囲気以下でどうなりますか

状況を把握してから変更します


Public Sub test1()
　　Call Samp1(Range("B2:B24"), 3, 2)
End Sub

Public Sub test2()
　　Call Samp1(Range("B2:B24"), 2, 3)
End Sub

Public Sub test3()
　　Call Samp1(Selection, 3, 2)
End Sub

Public Sub test4()
　　Call Samp1(Selection, 2, 3)
End Sub

Public Sub test5()
　　Call Samp1(ActiveCell, 3, 2)
End Sub

Public Sub test6()
　　Call Samp1(ActiveCell, 2, 3)
End Sub

Public Sub Samp1(rng As Range, iCf As Long, iCt As Long)
　　Dim r As Range
　　Dim iA() As Long
　　Dim i As Long, j As Long, k As Long, n As Long

　　For Each r In rng
　　　　k = -1
　　　　j = Len(r.Value)
　　　　i = 1
　　　　While (i <= j)
　　　　　　If (r.Characters(i, 1).Font.ColorIndex = iCf) Then
　　　　　　　　n = 1
　　　　　　　　Do While (i + n <= j)
　　　　　　　　　　If (r.Characters(i + n, 1).Font.ColorIndex <> iCf) Then
　　　　　　　　　　　　Exit Do
　　　　　　　　　　End If
　　　　　　　　　　n = n + 1
　　　　　　　　Loop
　　　　　　　　k = k + 1
　　　　　　　　ReDim Preserve iA(1, k)
　　　　　　　　iA(0, k) = i
　　　　　　　　iA(1, k) = n
　　　　　　　　i = i + n
　　　　　　End If
　　　　　　i = i + 1
　　　　Wend
　　
　　　　For i = 0 To k
　　　　　　r.Characters(iA(0, i), iA(1, i)).Font.ColorIndex = iCt
　　　　Next
　　Next
End Sub


※

>　　　　For i = 0 To k
>　　　　　　r.Characters(iA(0, i), iA(1, i)).Font.ColorIndex = iCt
>　　　　Next

この部分は、明示的に覚えたものがあるか判別した方が良いかも
（ k = -1 なら For 内は実行されませんが ）

　　If (k >= 0) Then
　　　　For i = 0 To k
　　　　　　r.Characters(iA(0, i), iA(1, i)).Font.ColorIndex = iCt
　　　　Next
　　End If

この回答へのお礼

ありがとうございます！
ExcelのVBAしか経験のない私にはかなり高度な内容でした。
30246kikuさんのように、いつか書けるようになりたいです！

Public Sub test3()
Call Samp1(Selection, 3, 2)
End Sub

を試してみました。

Samp1　の　ReDim Preserve iA(1, k)以下がまだ理解できておらず、※以下の部分が生かせていない状況です。そんな中途半端な状況でお礼を書くのは、大変失礼だと思いますが・・・<(_ _)>

No.1さんにも書いたのですが
(Will) we be in time for the plane if we leave now? No,you (won't.)
というように、文末のピリオドまで赤になっていた場合に、文末の　won't.　が白に変わってくれないのです。
でも、マクロを２回実行するとうまくいきます。

ですので、マクロ実行前に、ピリオドを黒に変更することにしました。
これならもちろん、瞬時に色を変更してくれます！

後半の部分、勉強させていただきます。ありがとうございました(^^)

お礼日時：2015/09/27 11:35