セル内の指定した文字だけ全部色を変更する

質問

初めて質問せて頂ます

指定した文字だけを変更することは可能なのですが
セル内にある指定した文字全部の色が変わらなくて困っています

マクロ初心者なもので大体インターネットから拾ってきたものをつなぎ合わせて使う程度の能力です

どなたか教えていただけませんでしょうか？
ちなみに「質問No.2769123」を参考にしましたがセルに含まれる文字は１つしか色が変わりません

例）セル内に指定した文字が10個あった場合全部色を変えたいと思っています

1つのセル内の文字「ABCD、ABCD、ABCD、ABCD、ABCD、ABBA、ABCD、ABBA、ABBA、ABCD…」
上記の場合ABBAの文字を全部赤に変えたいといった感じです

どうかよろしくお願いいたします

経緯としては検索した文字がヒットしたらその文字の色を変更したいと思ったからです

回答No.1

satoron666 · ベストアンサー

リンクなど貼ってもらえたら有難いです。

とりあえず、そのまま引用させてもらうと
Sub Macro1()
Dim rng As Range
Dim ptr As Integer
Const tStr As String = "ABC" 'ここに色を変える文字列を書く
　For Each rng In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 23)
　　ptr = InStr(rng.Value, tStr)
　　If ptr > 0 Then
　　　rng.Characters(Start:=ptr, Length:=Len(tStr)).Font.ColorIndex = 3
　　End If
　Next rng
End Sub

ですよね？？

Instr　というのは、中に文字列が含まれているかどうかを検索するものです。
この場合だと、含まれていたら、1回だけ実行するようなプログラムになっています。

そのセルに何度も含まれている場合は、ptrの部分も含め
繰り返す必要があります。

Sub Macro1()
Dim rng As Range
Dim ptr As Integer
Dim StartRange As Long
Const tStr As String = "ABBA" 'ここに色を変える文字列を書く
For Each rng In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 23)
StartRange = 1
Do
ptr = InStr(StartRange, rng.Value, tStr)'StartRangeの位置から、検索文字があるかどうか判別。
StartRange = ptr'検索後、StartRangeを更新する
If ptr > 0 Then
rng.Characters(Start:=StartRange, Length:=Len(tStr)).Font.ColorIndex = 3
StartRange = StartRange + Len(tStr)
End If
Loop Until ptr <= 0
Next rng
End Sub

んー、こんな感じでしょうか？（上手くいくかは不安ですが）
StartRangeというのは、セル内の検索位置になります。

お礼

satoron666様

大変ありがとうございました
おかげで全部色が付きました
自分でもなんとかさっき作成できたのですが
スマートじゃなく動作も遅かったので教えて頂いたものがとても良く感謝しております

以下自分が実際に使ったものです

tStr = Trim(Replace(FindWord, "*", " ")) 'ここに色を変える文字列を書く
tStr = Split(tStr, " ")
For Each rng In Sheets("検索結果").Cells.SpecialCells(xlCellTypeConstants, 23)
StartRange = 1
Do
For i = LBound(tStr) To UBound(tStr)
ptr = InStr(rng.Value, tStr(i))
ptr = InStr(StartRange, rng.Value, tStr(i)) 'StartRangeの位置から、検索文字があるかどうか判別。
StartRange = ptr '検索後、StartRangeを更新する
If ptr > 0 Then
rng.Characters(Start:=StartRange, Length:=Len(tStr(i))).Font.ColorIndex = 3
StartRange = StartRange + Len(tStr(i))
End If
Next
Loop Until ptr <= 0
Next rng

私が試行錯誤した微妙なものです＞ｗ＜
' Dim N As Integer
' Dim M As Integer
' tStr = Trim(Replace(FindWord, "*", " ")) 'ここに色を変える文字列を書く
' tStr = Split(tStr, " ")
' For Each rng In Sheets("検索結果").Cells.SpecialCells(xlCellTypeConstants, 23)
' For i = LBound(tStr) To UBound(tStr)
' ptr = InStr(rng.Value, tStr(i))
' If ptr > 0 Then
' For N = 1 To Len(rng.Text)
' For A = 0 To UBound(tStr)
' If Mid(rng.Text, N, Len(tStr(i))) = tStr(A) Then
' rng.Characters(Start:=N, Length:=Len(tStr(i))).Font.ColorIndex = 3
' End If
' Next A
' Next N
' End If
' Next i
' Next rng

回答No.2

30246kiku

基本的なものは以下になると思います

Public Sub Samp1()
　　Dim r As Range
　　Dim sS As String, sW As String
　　Dim iPos As Long

　　sS = "ABBA"

　　For Each r In Range("A1:A1000")
　　　　sW = r.Value
　　　　iPos = 1
　　　　Do While (iPos < Len(sW))
　　　　　　iPos = InStr(iPos, sW, sS)
　　　　　　If (iPos = 0) Then Exit Do
　　　　　　r.Characters(iPos, Len(sS)).Font.ColorIndex = 3
　　　　　　iPos = iPos + Len(sS)
　　　　Loop
　　Next
End Sub

InStr をヘルプで見てみると、１つ目の引数は何文字目から探すか・・・
なので、１文字目から探して・・・あったらその位置が返ってくるので
その位置から、検索文字数分の色を指定・・・
次を探す時には、その位置に検索文字数を加算した所から・・・
上記、検索文字 "ABBA" で、見つかった位置が 2 なら、次は 2 + 4 = 6 文字目から

> 経緯としては検索した文字がヒットしたらその文字の色を変更したい
事をやってみると、雰囲気以下に

Public Sub Samp2()
　　Dim r As Range
　　Dim sAddr As String
　　Dim sS As String, sW As String
　　Dim iPos As Long

　　sS = "ABBA"

　　Set r = Cells.Find(sS, LookAt:=xlPart)
　　If (Not r Is Nothing) Then
　　　　sAddr = r.Address
　　　　Do
　　　　　　sW = r.Value
　　　　　　iPos = 1
　　　　　　Do While (iPos < Len(sW))
　　　　　　　　iPos = InStr(iPos, sW, sS)
　　　　　　　　If (iPos = 0) Then Exit Do
　　　　　　　　r.Characters(iPos, Len(sS)).Font.ColorIndex = 3
　　　　　　　　iPos = iPos + Len(sS)
　　　　　　Loop
　　　　　　Set r = Cells.FindNext(r)
　　　　Loop While (r.Address <> sAddr)
　　End If
End Sub

今見ているシート全体を対象に、部分一致で検索し、なければ終わり・・・
あればセルのアドレスを覚えておいて、色付け処理
次のを求めて、覚えていたアドレスと同じなら処理を抜ける

お礼

30246kiku 様
ありがとうございます
解決しましたが参考にさせて頂きます