Excel VBA セル内の文字列操作について

質問

例えば、A列（A2より下のセル）のセル内にある文字列が、それぞれ対応するB列（B2より下のセル）のセル内にあった場合、該当文字列のフォントの色を変えたい（例えば「赤」）のですが、VBAで一括処理とかできるのでしょうか？

＜例＞
A列　　　　　　B列
テスト　　　　　このテストは・・・　→　「テスト」の部分のみ赤色にしたい。
サンプル　　　サンプル　　　　　→　文字列全部分の「サンプル」を赤色にしたい。

どうかご教示の程よろしくお願いいたします。

回答No.7

cj_mover · ベストアンサー

＃２、４、5、６、ｃｊです。
無駄があることに気が付いたので削りました。

Sub Re7730036ccr()
　　Dim r1 As Range, r2 As Range
　　Dim s1 As String, s2 As String
　　Dim nLen As Long, nPos As Long, i As Long

　　For Each r1 In Range("I2:I" & Cells(Rows.Count, "I").End(xlUp).Row)
　　　　s1 = r1.Value
　　　　nLen = Len(s1)
　　　　For Each r2 In r1.Range("B1,D1") ' Ｉ列を基準とした相対参照で範囲を指定。「,X1,Y1,Z1」のように追加可。
　　　　　　s2 = r2.Value
　　　　　　nPos = InStr(s2, s1)
　　　　　　Do While nPos > 0
　　　　　　　　r2.Characters(nPos, nLen).Font.Color = vbRed
　　　　　　　　nPos = InStr(nPos + nLen, s2, s1)
　　　　　　Loop
　　　　Next r2
　　Next r1
End Sub

お礼

できました。

すごいです。

本当にありがとうございます。

VBAっていろいろ出来るんですね。。。

この度は本当にありがとうございました。ｍ（＿）ｍ

回答No.8

tom04

続けてお邪魔します。

＞I列を基準にJ列、K列、L列にて処理するように

とありますので

cj_moverさんの方法の方が一般的な記述で効率的だと思いますが・・・
敢えて、回答させていただきます。

Sub test3()
Dim i As Long, j As Long, k As Long, str As String

'2行目～I列最終行まで
For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row '←9がI列の列番号です。
'J列～データがある列まで
For j = 10 To Cells(i, Columns.Count).End(xlToLeft).Column '←10がJ列の列番号となります。
If InStr(Cells(i, j), Cells(i, 9)) Then
For k = 1 To Len(Cells(i, j))
str = Mid(Cells(i, j), k, Len(Cells(i, 9)))
If str = Cells(i, 9) Then
Cells(i, j).Characters(Start:=k, Length:=Len(Cells(i, 9))).Font.ColorIndex = 3
End If
Next k
End If
Next j
Next i
End Sub

※　各セルを1文字ずつ舐めるように検索していますので、ちょっと効率が悪いと思います。m(_ _)m

お礼

できました。

すごいです。

本当にありがとうございます。

VBAっていろいろ出来るんですね。。。

この度は本当にありがとうございました。ｍ（＿）ｍ

大変申し訳ありませんが、べストアンサーは、#7さんにさせていただきました。

回答No.6

cj_mover

＃２、４、5、ｃｊです。

Sub Re7730036ccq()
　　Dim r As Range, r2 As Range
　　Dim s1 As String, s2 As String
　　Dim nLen As Long, nPos As Long, nBtmRow As Long
　　Dim i As Long

　　nBtmRow = Cells(Rows.Count, "I").End(xlUp).Row
　　For Each r In Range("I2:L" & nBtmRow).Rows
　　　　s1 = r.Cells(1).Value
　　　　nLen = Len(s1)
　　　　For Each r2 In r.Range("B1,D1") ' Ｉ列を基準とした相対参照で範囲を指定。「,X1,Y1,Z1」のように追加可。
　　　　　　s2 = r2.Value
　　　　　　nPos = InStr(s2, s1)
　　　　　　Do While nPos > 0
　　　　　　　　r2.Characters(nPos, nLen).Font.Color = vbRed
　　　　　　　　nPos = InStr(nPos + nLen, s2, s1)
　　　　　　Loop
　　　　Next r2
　　Next r
End Sub

回答No.5

cj_mover

＃２、４、ｃｊです。失礼しました。
間違えてましたので訂正です。

Sub Re7730036cc()
　　Dim r As Range, r2 As Range
　　Dim s1 As String, s2 As String
　　Dim nLen As Long, nPos As Long
　　Dim i As Long
　　Dim nBtmRow As Long
　　nBtmRow = Cells(Rows.Count, 1).End(xlUp).Row
　　For Each r In Range("A2:C" & nBtmRow).Rows
　　　　s1 = r.Cells(1).Value
　　　　nLen = Len(s1)
　　　　For Each r2 In r.Columns("B:C").Cells' 列範囲を拡張する」場合はここの行の C を変更。
　　　　　　s2 = r2.Value
　　　　　　nPos = InStr(s2, s1)
　　　　　　Do While nPos > 0
　　　　　　　　r2.Characters(nPos, nLen).Font.Color = vbRed
　　　　　　　　nPos = InStr(nPos + 1, s2, s1)
　　　　　　Loop
　　　　Next r2
　　Next r
End Sub

回答No.4

cj_mover

＃２、ｃｊです。補足読みました。
B:C列のように連続した列を書式置換対象にするのであれば
容易に列範囲を拡張出来るように書きました。
For Each Next で書いていますから、少しパフォーマンスも向上しています。
（少しだけむずかしい書き方ですけど、基本的ではあります。）

Sub Re7730036cc()
　　Dim r As Range, r2 As Range
　　Dim s1 As String, s2 As String
　　Dim nLen As Long, nPos As Long
　　Dim i As Long
　　Dim nBtmRow As Long
　　nBtmRow = Cells(Rows.Count, 1).End(xlUp).Row
　　With Range("A2:C" & nBtmRow)　' 列範囲を拡張する」場合はここの C を変更。

　　　　For Each r In .Rows
　　　　　　s1 = r.Cells(1).Value
　　　　　　nLen = Len(s1)
　　　　　　For Each r2 In r.Columns("B:C").Cells
　　　　　　　　s2 = r2.Value
　　　　　　　　nPos = InStr(s2, s1)
　　　　　　　　Do While nPos > 0
　　　　　　　　　　r2.Characters(nPos, nLen).Font.Color = vbRed
　　　　　　　　　　nPos = InStr(nPos + 1, s2, s1)
　　　　　　　　Loop
　　　　　　Next r2
　　　　Next r
　　End With
End Sub

補足

お手数おかけしております。

実は、

今回の質問では、A列に対し、B,C列にてお願いしておりましたが、
実際には、I列に対して、J列とL列になっております。

連続した列であれば、上記コードで可能ということでしたので、
I列を基準にJ列、K列、L列にて処理するように加工しようとしましたが、
上手くいきませんでした＞＜

上記コードの場合、どこを修正すればよろしいのでしょうか？

何度もお手数おかけいたしておりますが、何卒ご教示の程お願いいたします。

回答No.3

tom04

No.1です。
補足に
＞A列の文字列からB列とC列の対象文字列という感じで複数のセル列に・・・
とありますので、
B列以降すべての列に対応するようにしてみました。
（今回はセル内にA列の文字が複数あっても大丈夫です）

Sub test2()
Dim i As Long, j As Long, k As Long, str As String
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
If InStr(Cells(i, j), Cells(i, 1)) Then
For k = 1 To Len(Cells(i, j))
str = Mid(Cells(i, j), k, Len(Cells(i, 1)))
If str = Cells(i, 1) Then
Cells(i, j).Characters(Start:=k, Length:=Len(Cells(i, 1))).Font.ColorIndex = 3
End If
Next k
End If
Next j
Next i
End Sub

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

補足

お手数おかけしております。

実は、

今回の質問では、A列に対し、B,C列にてお願いしておりましたが、
実際には、I列に対して、J列とL列になっております。

A列に対し、Ｂ列以降であれば、上記コードで可能ということでしたので、
I列を基準にJ列以降にて処理するように加工しようとしましたが、
上手くいきませんでした＞＜

上記コードの場合、どこを修正すればよろしいのでしょうか？

何度もお手数おかけいたしておりますが、何卒ご教示の程お願いいたします。

回答No.2

cj_mover

こんにちは。
一応、簡単な例で、
該当文字列が複数ある場合にも対応するように書いています。

Sub Re7730036c()
　　Dim s1 As String, s2 As String
　　Dim nLen As Long, nPos As Long
　　Dim i As Long
　　For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
　　　　s1 = Cells(i, 1).Value
　　　　With Cells(i, 2)
　　　　　　s2 = .Value
　　　　　　nLen = Len(s1)
　　　　　　nPos = InStr(s2, s1)
　　　　　　Do While nPos > 0
　　　　　　　　.Characters(nPos, nLen).Font.Color = vbRed
　　　　　　　　nPos = InStr(nPos + 1, s2, s1)
　　　　　　Loop
　　　　End With
　　Next i
End Sub

補足

あ、ありがとうございます。
すごいです。できました。
こんなこともできるんですね。。。。

因みになんですが、

A列の文字列からB列とC列の対象文字列という感じで複数のセル列に指定はできるのでしょうか？

追加質問で大変恐縮ですが、ご教示の程よろしくお願いいたします。

回答No.1

tom04

こんにちは！
一例です。

データは2行目からあるとして・・・

Sub test()
Dim i As Long, k As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If InStr(Cells(i, 2), Cells(i, 1)) Then
k = WorksheetFunction.Find(Cells(i, 1), Cells(i, 2))
Cells(i, 2).Characters(Start:=k, Length:=Len(Cells(i, 1))).Font.ColorIndex = 3
End If
Next i
End Sub

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

補足

あ、ありがとうございます。
すごいです。できました。
こんなこともできるんですね。。。。

因みになんですが、

A列の文字列からB列とC列の対象文字列という感じで複数のセル列に指定はできるのでしょうか？

追加質問で大変恐縮ですが、ご教示の程よろしくお願いいたします。