vba:セル内変更文字列の色付け

質問

vbaにて別ブックの一覧を参照し、
指定範囲に検索文字列が含まれる場合
文字列の置換&対象セルの色付け&
件数の表示を行うコードから、

文字列の置換&セル内の変更した文字列のみ
色付け&件数の表示を行うコードに変更したいです。

変更した文字列のみ文字色を変更したい場合、
どのようなコードに書き換えればよろしいでしょうか。

なお、現在のコードは以下の通りです。

============================
Sub 複数条件で一括置換する()

Dim 範囲 As Object
Dim 対象 As Object
Dim 一覧 As Variant

Set 範囲 = Selection

一覧 = Workbook("確認.xlsm").Sheets("複数条件").Range("A1:B7")

Dim tmp As Variant
Dim mCnt As Long

中略

mCnt = 0

For Each 対象 In 範囲

For i = LBound(一覧, 1) To UBound(一覧, 1)

tmp = 対象.Value

対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))

If tmp <> 対象.Value Then
対象.Interior.Color = vbRed
mCnt = mCnt + 1
End If

Next
Next

MsgBox mCnt & "件置換しました"

Set 範囲 = Nothing
Set 対象 = Nothing

End Sub

回答No.9

kkkkkm · ベストアンサー

回答No.8の補足です。

回答No.6の補足に記載があったコードで、変数宣言が足りなかったので以下を追加しておいてください。

Dim m As Long, n As Long, i As Long

マクロの画面の「ツール」「オプション」で「変数の宣言を強制する」にチェックを入れておくと宣言の不足が防げます。

また、一応試しに

Color = vbRed
を
ColorIndex = 3

にしてみたらどうでしょう。
以下の2か所です。

If 対象.Characters(n, 1).Font.ColorIndex = 3 Then

対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.ColorIndex = 3

補足

追加の回答をいただきありがとうございます！

変更を行いましたが、色が変更されず
いろいろ試していたところ、
置換前の文字列のみを置換対象とした場合
色づかないことがわかりました！

置換前の文字列のみがセルの中に含まれることはないので、一旦このまま運用したいと思います🙇🏻‍♀️

また、【for each 対象 in 選択範囲】以降のコードについて、わたしの理解が追いつかず、お手数ですが簡単な解説をご教示いただけますと幸いです、、

回答No.12

kkkkkm

対象の文字列の後ろ、置換後の文字列数分は検索の必要なし
で考えていたのですが

> 置換前の文字列のみを置換対象とした場合
> 色づかないことがわかりました！

上記の場合は、Len(対象.Value) - Len(MVar(k))が0になるので色付けループに入りませんでした。
最低一回はループするように

For j = 1 To Len(対象.Value) - Len(MVar(k))
を
For j = 1 To Len(対象.Value) - Len(MVar(k)) + 1
に変更してみてください。

回答No.11

kkkkkm

> また、【for each 対象 in 選択範囲】以降のコードについて、わたしの理解が追いつかず、お手数ですが簡単な解説をご教示いただけますと幸いです、、

For Each 対象 In 範囲
MFlg = False '置換したかどうか判別のフラグ
m = 0 '置換した数分配列に保存するための配列要素数のカウンタ

検索文字列一覧の数だけループします。
↓
For i = LBound(一覧, 1) To UBound(一覧, 1)

置換対象に検索文字列あればその位置を返すので0でなければ検索文字列を含む事になります。
検索文字列一覧に空白セルがあった場合にはそこはスキップするように 一覧(i, 1) <> ""があります。
↓
If InStr(対象.Value, 一覧(i, 1)) > 0 And 一覧(i, 1) <> "" Then
対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))

置換が実行された置換後の文字列を置換文字列分だけ配列変数に保存します。文字の色付けに使います。
↓
ReDim Preserve MVar(m)
MVar(m) = 一覧(i, 2)
MFlg = True
m = m + 1
End If
Next
↑
ひとつの対象、置換終わり
ひとつの対象、文字列の色つけ
↓
If MFlg = True Then
mCnt = mCnt + 1 '置換した数のカウンタ

ひとつの対象で置換した数だけループ
↓
For k = LBound(MVar) To UBound(MVar)

置換後の対象の文字の中で置換後の文字列を探す「j」は探し始めの位置
↓
For j = 1 To Len(対象.Value) - Len(MVar(k))'対象の文字列の後ろ、置換後の文字列数分は検索の必要なし

置換後の対象に置換後文字列あればその位置を返すので0でなければ置換後文字列を含む事になります。
置換後文字列配列変数の中に空白だけがあった場合にはそこはスキップするように MVar(k) <> ""があります。
↓
If InStr(j, 対象.Value, MVar(k)) > 0 And MVar(k) <> "" Then

置換後文字列の現れた最初の文字位置からループ
↓
For n = InStr(j, 対象.Value, MVar(k)) To Len(対象.Value) - Len(MVar(k))

見つかった文字列の先頭(n文字目)に既に色付けがあれば、次の探し始めを見つかった文字列の先頭の次に「j」を変更して再度検索
色付けが見つからなくなるまでループ、色付けが見つからなければループを抜ける
回答No.6の訂正箇所です。
↓
If 対象.Characters(n, 1).Font.Color = vbRed Then
j = InStr(j, 対象.Value, MVar(k)) + 1
Else
Exit For
End If
Next

最後の色付け位置の先頭位置の次が「j」に入っているので「j」以降で検索して見つかった置換後文字列に色付け
次の色付けの探し始めを「j」にセット
↓
対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed
j = InStr(j, 対象.Value, MVar(k)) + Len(MVar(k)) - 1
Else
Exit For
End If
Next
Next
End If
↓ひとつの対象セル分置換色付けが終わり次のセルに
Next

回答No.10

kkkkkm

あと、条件付き書式でフォントの色を指定している場合、状況によって実行後に条件付き書式の色のままの事があります。(変更されるパターンもあります)

回答No.8

kkkkkm

> 変更後
> Set 範囲 = Application.InputBox("置換を行う範囲を設定してください", Type:=8)

私は変ではないと思います。私も先日違う質問にこの方法を提案しました。

ただ、キャンセルした場合エラーになりますので以下のようにしていおくといいと思います。

On Error Resume Next
Set 範囲 = Application.InputBox("置換を行う範囲を設定してください", Type:=8)
On Error GoTo 0

If 範囲 Is Nothing Then
MsgBox "範囲選択が間違ってるかキャンセルされました", vbInformation
Exit Sub
End If

> 文字列の変換と件数表示はされるのですが、文字列の色付けがされません。

とのことなのですが、こちらで記載されたコードをコピペして実行したところ「赤色」に色付けされました。
添付画像参照してください。

一度以下の所にDebug.Print MVar(k)を入れてイミディエイトウインドウに置換後の文字列が出るかどうか見てみてください。

If MFlg = True Then
mCnt = mCnt + 1
For k = LBound(MVar) To UBound(MVar)

Debug.Print MVar(k)'←ここです

For j = 1 To Len(対象.Value) - Len(MVar(k))

回答No.7

HohoPapa

課題に興味を惹かれ、
置換のと置換した文字列部分に色をつけるコードを書いてみました。
よかったら参考にしてください。

以下、使う上でのポイントです。
添付画像のように、
対象ブックのフルパス、置換前後の文字列、染める色を指定して実行します。

ヒット数、ヒットしたシートとセルアドレスを一覧にしています。

なお、コード中の
Dim ChgPos(50) As Long　'色を染める開始文字位置
これは、１つのセルに置換対象の文字列が最大50以下と想定しています。
必要に応じて増減して使ってください。

また、詳しくはコードを読んでください。

Sub Sample()

　Dim FText As String　'置換前文字列
　Dim TText As String　'置換後文字列
　Dim PutColor As Double　'置き換えた文字列も文字色
　Dim TgWb As Workbook　'対象ブック
　Dim TgWs As Worksheet　'対象シート
　Dim TgCell As Range　　'対象セル
　Dim c As Long 'セル文字のカウンター
　Dim CLen As Long '対象セルの文字列長
　Dim PutText As String　'置き換え後総文字列
　Dim HitCnt As Long　　'セル内でのヒット数
　Dim r As Long　　　'ヒット用カウンター
　Dim ChgPos(50) As Long　'色を染める開始文字位置
　Dim ShCnt As Long　　'シート数
　Dim s As Long　　'シートカウンター
　Dim HitTotal As Long　'ヒット数総計
　Dim CtlSh As Worksheet　'条件設定シート

　Set CtlSh = ThisWorkbook.Sheets(1)
　Set TgWb = Workbooks.Open(CtlSh.Cells(2, 3).Value)
　FText = CtlSh.Cells(3, 3).Value
　TText = CtlSh.Cells(4, 3).Value
　PutColor = CtlSh.Cells(5, 3).Font.Color

　HitTotal = 0
　ShCnt = TgWb.Sheets.Count
　HitCnt = 0
　For s = 1 To ShCnt
　　For Each TgCell In TgWb.Sheets(s).UsedRange
　　　HitCnt = 0
　　　If Len(TgCell.Value) >= Len(FText) Then
　　　　CLen = Len(TgCell.Value) 'セルのテキストの文字長
　　　　PutText = ""
　　　　c = 1

　　　　Do

　　　　　If c > CLen - Len(FText) + 1 Then Exit Do

　　　　　If Mid(TgCell.Value, c, Len(FText)) = FText Then
　　　　　　HitCnt = HitCnt + 1
　　　　　　HitTotal = HitTotal + 1
　　　　　　CtlSh.Cells(HitTotal + 10, 2).Value = TgWb.Sheets(s).Name
　　　　　　CtlSh.Cells(HitTotal + 10, 3).Value = TgCell.Address
　　　　　　PutText = PutText & TText
　　　　　　ChgPos(HitCnt) = c + ((HitCnt - 1) * (Len(TText) - Len(FText)))
　　　　　　c = c + Len(FText)
　　　　　Else
　　　　　　PutText = PutText & Mid(TgCell.Value, c, 1)
　　　　　　c = c + 1
　　　　　End If

　　　　Loop

　　　　If c <= CLen Then
　　　　　PutText = PutText & Mid(TgCell.Value, c, CLen - c + 1)
　　　　End If

　　　　TgCell.Value = PutText

　　　　For r = 1 To HitCnt
　　　　　TgCell.Characters(Start:=ChgPos(r), Length:=Len(TText)). _
　　　　　　Font.Color = PutColor
　　　　Next r

　　　End If

　　Next TgCell

　Next s

　CtlSh.Cells(7, 3).Value = HitTotal

　TgWb.Save
　TgWb.Close

End Sub

回答No.6

kkkkkm

No.5の

> あいうえおかき
> があって
> えお→さし
> かき→しし
> に置換した結果の
> あいうさししし
> は
> 「あいう」が元の色で「さしし」が赤「し」が元の色となります。

を
「あいう」が元の色で「さししし」が赤になるようにしました。

No.5の

> If InStr(j, 対象.Value, MVar(k)) > 0 And MVar(k) <> "" Then
> 対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed

の2行を以下に変更してください。

If InStr(j, 対象.Value, MVar(k)) > 0 And MVar(k) <> "" Then

For n = InStr(j, 対象.Value, MVar(k)) To Len(対象.Value) - Len(MVar(k))
If 対象.Characters(n, 1).Font.Color = vbRed Then
j = InStr(j, 対象.Value, MVar(k)) + 1
Else
Exit For
End If
Next

対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed

補足

ご回答いただきありがとうございます！

回答いただいた内容で何点か確認させていただきたく、存じます。

1.最終的なコードは以下でお間違い無いでしょうか？
文字列の変換と件数表示はされるのですが、文字列の色付けがされません。
誤っている箇所があれば、ご指摘いただければ幸いです。

2.確認.xlsmにvbaを組み、個人用マクロから確認.xlsmの以下vbaを実行する流れとしたいです。（置換対象となるブックが毎回異なる為）
その場合、以下の通り変更して対象範囲を毎回選べるようにできればと思うのですが、この方法はvbaに詳しい方からみて変でしょうか？

変更前
Set 範囲 = Selection

変更後
Set 範囲 = Application.InputBox("置換を行う範囲を設定してください", Type:=8)

====================

Sub 複数条件で一括置換する()

Dim 範囲 As Object
Dim 対象 As Object
Dim 一覧 As Variant
Dim MVar() As Variant
Dim MFlg As Boolean
Dim j As Long, k As Long
Dim tmp As Variant
Dim mCnt As Long

Set 範囲 = Selection

一覧 = Workbooks("確認.xlsm").Sheets("複数条件").Range("A1:B7")

mCnt = 0

Application.ScreenUpdating = False
For Each 対象 In 範囲
MFlg = False
m = 0

For i = LBound(一覧, 1) To UBound(一覧, 1)
If InStr(対象.Value, 一覧(i, 1)) > 0 And 一覧(i, 1) <> "" Then
対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))
ReDim Preserve MVar(m)
MVar(m) = 一覧(i, 2)
MFlg = True
m = m + 1
End If
Next
If MFlg = True Then
mCnt = mCnt + 1
For k = LBound(MVar) To UBound(MVar)
For j = 1 To Len(対象.Value) - Len(MVar(k))

If InStr(j, 対象.Value, MVar(k)) > 0 And MVar(k) <> "" Then

For n = InStr(j, 対象.Value, MVar(k)) To Len(対象.Value) - Len(MVar(k))
If 対象.Characters(n, 1).Font.Color = vbRed Then
j = InStr(j, 対象.Value, MVar(k)) + 1
Else
Exit For
End If
Next

対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed

j = InStr(j, 対象.Value, MVar(k)) + Len(MVar(k)) - 1
Else
Exit For
End If
Next
Next
End If
Next
Application.ScreenUpdating = True
MsgBox mCnt & "件置換しました"

回答No.5

kkkkkm

度々の訂正です。一部勘違いがありました。

あと

あいうえおかき
があって
えお→さし
かき→しし
に置換した結果の
あいうさししし
は
「あいう」が元の色で「さしし」が赤「し」が元の色となります。

Application.ScreenUpdating = False
For Each 対象 In 範囲
MFlg = False
m = 0
'複数条件の数分処理を繰り返します。
For i = LBound(一覧, 1) To UBound(一覧, 1)
If InStr(対象.Value, 一覧(i, 1)) > 0 And 一覧(i, 1) <> "" Then
対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))
ReDim Preserve MVar(m)
MVar(m) = 一覧(i, 2)
MFlg = True
m = m + 1
End If
Next
If MFlg = True Then
mCnt = mCnt + 1
For k = LBound(MVar) To UBound(MVar)
For j = 1 To Len(対象.Value) - Len(MVar(k))
If InStr(j, 対象.Value, MVar(k)) > 0 And MVar(k) <> "" Then
対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed
j = InStr(j, 対象.Value, MVar(k)) + Len(MVar(k)) - 1
Else
Exit For
End If
Next
Next
End If
Next
Application.ScreenUpdating = True
MsgBox mCnt & "件置換しました"

回答No.4

kkkkkm

No.3の訂正です。

時によって先頭の文字の色が変更されることがあったので訂正しました。
無駄なループを抜けるようにしました。
画面描画を一旦停止したほうが早そうなので一旦停止しています。

前略

Application.ScreenUpdating = False
For Each 対象 In 範囲
MFlg = False
'複数条件の数分処理を繰り返します。
For i = LBound(一覧, 1) To UBound(一覧, 1)
If InStr(対象.Value, 一覧(i, 1)) > 0 And 一覧(i, 1) <> "" Then
対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))
ReDim Preserve MVar(i - 1)
MVar(i - 1) = 一覧(i, 2)
MFlg = True
End If
Next
If MFlg = True Then
mCnt = mCnt + 1
For k = LBound(MVar) To UBound(MVar)
For j = 1 To Len(対象.Value) - Len(MVar(k))
If InStr(j, 対象.Value, MVar(k)) > 0 Then
対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed
j = InStr(j, 対象.Value, MVar(k)) + Len(MVar(k)) - 1
Else
Exit For
End If
Next
Next
End If
Next
Application.ScreenUpdating = True
MsgBox mCnt & "件置換しました"

後略

回答No.3

kkkkkm

No.2の追加です。

同一セルで2か所以上置換がある場合は以下のようにしてみてください。

Dim MVar() As Variant
Dim MFlg As Boolean
Dim j As Long, k As Long

を追加して

前略

For Each 対象 In 範囲
MFlg = False
'複数条件の数分処理を繰り返します。
For i = LBound(一覧, 1) To UBound(一覧, 1)
If InStr(対象.Value, 一覧(i, 1)) > 0 And 一覧(i, 1) <> "" Then
対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))
ReDim Preserve MVar(i - 1)
MVar(i - 1) = 一覧(i, 2)
' mCnt = mCnt + 1
MFlg = True
End If
Next
If MFlg = True Then
mCnt = mCnt + 1
For k = LBound(MVar) To UBound(MVar)
For j = 1 To Len(対象.Value) - Len(MVar(k))
対象.Characters(Start:=InStr(j, 対象.Value, MVar(k)), Length:=Len(MVar(k))).Font.Color = vbRed
Next
Next
End If
Next
MsgBox mCnt & "件置換しました"

後略

回答No.2

kkkkkm

No.1の追加です。
文字色を変更した後でReplaceが実行されると途中の文字色が先頭の文字色で統一されてしまうので、他の部分も以下のように変更してください。ただし、同一セルで2か所置換された場合あとから見つかった方だけに色が付きます。

For i = LBound(一覧, 1) To UBound(一覧, 1)
' tmp = 対象.Value　無し
If InStr(対象.Value, 一覧(i, 1)) > 0 And 一覧(i, 1) <> "" Then

対象.Value = Replace(対象.Value, 一覧(i, 1), 一覧(i, 2))
' If tmp <> 対象.Value Then　無し
' 対象.Interior.Color = vbRed　無し
対象.Characters(Start:=InStr(対象.Value, 一覧(i, 2)), Length:=Len(一覧(i, 2))).Font.Color = vbRed
mCnt = mCnt + 1
End If
Next