[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Excelで置換した文字に色をつけたい』（こうめ）
Excelで、「対象シート」のB列を参照して、 「置換リスト」シートの一覧のC列の文字列をE列の文字列に置換するようにしています。 「対象シート」のA列には置換前のデータも入っているので、 「対象シート」のA列、B列それぞれの置換前、置換後の文字列に色をつけたいと思っています。 どの文字がどの文字に置換されたかを比較するためです。
置換後のB列のみ下記式で色をつけられたのですが、 該当文字が含まれる、セル内全部の文字の色が変わってしまいました。 該当文字だけの色を変えるにはどうすればよいでしょうか。 また、「置換リスト」シートのC列にある場は「対象シート」のA列の該当文字のみを赤くする方法も教えていただけないでしょうか。
Sub list置換_Click()
Dim list_sheet As Worksheet
Dim chg_sheet As Worksheet
'こっちは置換する元の文字と置換文字のリスト
Set list_sheet = Worksheets("置換リスト")
'こっちは一括置換したい対象のシート
Set chg_sheet = Worksheets("対象シート")
cnt = list_sheet.Range("c4").CurrentRegion.Rows.Count
For i = 4 To cnt
srcword = list_sheet.Cells(i, "C").Value
repword = list_sheet.Cells(i, "E").Value
With Application.ReplaceFormat.Font
.Subscript = False
.Color = 255
.TintAndShade = 0
End With
Columns("B:B").Replace What:=srcword, Replacement:=repword, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
Next i
End Sub
よろしくお願いいたします。
標準機能の置換では、文字列の部分書式設定が出来ないようなので、 マクロで処理を実装した例です。 こんな感じのことでしょうか。 (Mook)
Option Explicit
Sub list置換_Click()
Dim list_sheet As Worksheet
Dim chg_sheet As Worksheet
'こっちは置換する元の文字と置換文字のリスト
Set list_sheet = Worksheets("置換リスト")
'こっちは一括置換したい対象のシート
Set chg_sheet = Worksheets("対象シート")
Dim cnt As Long
cnt = list_sheet.Range("c4").CurrentRegion.Rows.Count
Dim i As Long
Dim srcWord As String
Dim repWord As String
For i = 4 To cnt
srcWord = Trim(list_sheet.Cells(i, "C").Value)
repWord = Trim(list_sheet.Cells(i, "E").Value)
If Len(srcWord) > 0 And Len(repWord) > 0 Then
MyReplace chg_sheet.Columns("A:A"), srcWord, srcWord
MyReplace chg_sheet.Columns("B:B"), srcWord, repWord
End If
Next
End Sub
Sub MyReplace(rng As Range, srcWord, repWord)
Dim res As Range
Set res = rng.Find(srcWord)
If res Is Nothing Then Exit Sub
Dim fRes As Range
Set fRes = res
Dim stpos As Long
Do
res.Value = Replace(res.Value, srcWord, repWord)
stpos = 1
Do While InStr(stpos, res.Value, repWord) > 0
stpos = InStr(stpos, res.Value, repWord)
res.Characters(stpos, Len(repWord)).Font.ColorIndex = 3
stpos = stpos + Len(repWord)
Loop
Set res = rng.FindNext
If res Is Nothing Then Exit Sub
Loop While fRes.AddressLocal <> res.AddressLocal
End Sub
Mookさん 早速の回答ありがとうございます。 置換後の文字には色をつけることができました！ ありがとうございます。 感激です！！！ ただ、置換前のA列がやはりセル内全ての文字が赤く変わってしまいました。。
自分でも記載していただいたマクロをもう一度じっくり解読してみようと思いますが、 もしおわかりになれば、教えていただけると嬉しいです。
よろしくお願いいたします。
追記です。 B列のセルの中に置換文字が１つの場合はうまくいくのですが、 複数の置換文字がある場合、やはりセル内の全ての文字が赤くなってしまうようです。。。
複数該当するものがある場合、最後の結果しか反映しないという 現象は確認しましたが、全部赤くなるというのはデータ起因のような気がします。
シートの限定の追加と、空白があった場合の対応を追加してみましたが、 これでも現象が出るでしょうか。
ステップ実行のやり方をご存知だったら、どの変換でそうなっているか確認して みれるでしょうか？ (Mook)
ステップ実行したところ、3回目の「stpos = 1」で、A列全部が赤くなり、 4回目の「stpos = 1」で、B列全部の文字が赤くなりました。
「対象シート」のA1とB1に「標準パソコンを再起動してください」と入力されており、
[置換リスト]には4行目から、今仮で以下のデータが入っています。
C列 E列 標準パソコン Standard personal computer 再起動 reboot 標準プリンタ Standard printer メモ memo ああああ aaaa いいいい iiii ええええ eeeee おおおお ooooo
Excel2000でA1に「標準パソコンを再起動してください」と入力し 「標準パソコン」だけを赤色にした状態で Ctrl+H で再起動をrebootに置換したところ、そのセルの文字すべてが赤色になりました。 「準パソコン」が赤の場合は全て黒に変わりました。 全ての文字が一文字目の色に変わります。 仕様のようです。 (cai)
あぁ、懸念していた状況が起きそうですね。 一つの行の中を複数回置換するのは、提示したやり方ではうまくいかないようです。
セルの値を書き換えてしまうと、前の状態が消えてしまいますが、 Characters を操作すれば、上手くいきそうです。 こんな感じでどうでしょうか。 (Mook)
Option Explicit
Sub list置換_Click()
Dim list_sheet As Worksheet
Dim chg_sheet As Worksheet
'こっちは置換する元の文字と置換文字のリスト
Set list_sheet = Worksheets("置換リスト")
'こっちは一括置換したい対象のシート
Set chg_sheet = Worksheets("対象シート")
Dim cnt As Long
cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Row
Dim i As Long
Dim srcWord As String
Dim repWord As String
For i = 4 To cnt
srcWord = Trim(list_sheet.Cells(i, "C").Value)
repWord = Trim(list_sheet.Cells(i, "E").Value)
If Len(srcWord) > 0 And Len(repWord) > 0 Then
MyReplace chg_sheet.Range("A:A"), srcWord, srcWord
MyReplace chg_sheet.Range("B:B"), srcWord, repWord
End If
Next
End Sub
Sub MyReplace(rng As Range, srcWord, repWord)
Dim res As Range
Set res = rng.Find(what:=srcWord, LookAt:=xlPart)
If res Is Nothing Then Exit Sub
Dim fRes As Range
Set fRes = res
Dim stpos As Long
Do
stpos = 1
Do While InStr(stpos, res.Value, srcWord) > 0
stpos = InStr(stpos, res.Value, srcWord)
res.Characters(stpos, Len(srcWord)).Delete
res.Characters(stpos, 0).Insert repWord
res.Characters(stpos, Len(repWord)).Font.ColorIndex = 3
stpos = stpos + Len(repWord)
Loop
Set res = rng.FindNext
If res Is Nothing Then Exit Sub
Loop While fRes.AddressLocal <> res.AddressLocal
End Sub
データ配置が私の理解した通りなら、これでも
Sub test()
Dim beforeRng As Range, afterRng As Range
Dim r As Range, c As Range
Dim beforeTxt As String, afterTxt As String
Dim m As Object
Set beforeRng = Sheets("置換リスト").Range("c4").CurrentRegion
With Sheets("対象シート")
Set afterRng = .Range("a1", .Cells.SpecialCells(11)).Resize(, 2)
End With
With CreateObject("VBScript.RegExp")
.Global = True
For Each r In beforeRng.Columns(1).Cells
beforeTxt = r.Value
afterTxt = r(, 3).Value
For Each c In afterRng.Columns(1).Cells
.Pattern = beforeTxt
If .test(c.Value) Then
For Each m In .Execute(c.Value)
c.Characters(m.firstindex + 1, m.Length) _
.Font.Color = vbRed
Next
End If
If .test(c(, 2).Value) Then
c(, 2).Value = .Replace(c(, 2).Value, afterTxt)
.Pattern = afterTxt
For Each m In .Execute(c(, 2).Value)
c(, 2).Characters(m.firstindex + 1, m.Length) _
.Font.Color = vbRed
Next
End If
Next
Next
End With
Set beforeRng = Nothing
Set afterRng = Nothing
End Sub
(seiya)
>Mookさん ありがとうございます。 「実行時エラー '450' 引数の数が一致していません。または不正なプロパティを指定しています。」 が表示されて、「cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Rows.End」 部分が黄色になってしまいました。。。 なかなかうまくいかないですね。
>seiyaさん ありがとうございます。 実行してみたのですが、無反応でした。 データ配置のせいかと思いますので、記載してくださったコードをがんばって読み解いてみようと思います。
cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Rows.End
を「cnt = list_sheet.Range("C4").End(xlDown).Row」に修正したら、
エラーは出ず、B列はすべて問題なくフォントを赤くできました！
ただ、原本のA列の文字がところどころ赤くならないようです。
あっ、ごめんなさい。 ちょくぜんになおしたところが。
cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Rows.End を cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Row にしてください。 (Mook)
Mookさん 早速ありがとうございます。 「cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Row」でも エラーでなくなりました！ ただ、やはりA列のデータがところどころ赤くならず、、、 なかなか、難しいです、、
どうやら、A列内で同じ単語が発生した場合、1番上のものだけが赤くなり、 2番目からが赤くならないような感じですね。 複数同じ単語がある場合の条件追記を考えてみます。
ちょっと修正
依然として配置が不安ですが...
Sub test()
Dim beforeRng As Range, afterRng As Range, r As Range
Dim myPtn() As String, myReplace() As String
Dim i As Long, n As Long
Dim m As Object, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Set beforeRng = Sheets("置換リスト").Range("c4").CurrentRegion
For Each r In beforeRng.Columns(1).Cells
dic(r.Value) = r(, 3).Value
Next
Set beforeRng = Nothing
With Sheets("対象シート")
Set afterRng = .Range("a1", .Cells.SpecialCells(11)).Resize(, 2)
End With
With CreateObject("VBScript.RegExp")
.Global = True
For Each r In afterRng.Columns(1).Cells
.Pattern = Join$(dic.keys, "|")
If .test(r.Value) Then
ReDim myReplace(1 To .Execute(r.Value).Count), _
myPtn(1 To .Execute(r.Value).Count)
n = 0
For Each m In .Execute(r.Value)
r.Characters(m.firstindex + 1, m.Length) _
.Font.Color = vbRed
n = n + 1
myReplace(n) = dic(m.Value)
myPtn(n) = m.Value
Next
For i = 1 To n
.Pattern = myPtn(i)
If .test(r(, 2).Value) Then
r(, 2).Value = .Replace(r(, 2).Value, myReplace(i))
End If
Next
.Pattern = Join$(myReplace, "|")
For Each m In .Execute(r(, 2).Value)
r(, 2).Characters(m.firstindex + 1, m.Length).Font.Color = vbRed
Next
End If
Next
End With
Set afterRng = Nothing
Set dic = Nothing
End Sub
(seiya)
>seiyaさん ありがとうございます。 開始位置の問題か、うまくうごきませんでした。。。
こちらでも確認してみましたが、どうも Find の挙動が思い通りに動いていないようです。 値を変更しながらだと FindNext が期待通りに動かないのかな？ とりあえず、Find を使わない方法に変更してみました。 (Mook)
Option Explicit
Sub list置換_Click()
'こっちは置換する元の文字と置換文字のリスト
Dim list_sheet As Worksheet
Set list_sheet = Worksheets("置換リスト")
'こっちは一括置換したい対象のシート
Dim change_sheet As Worksheet
Set change_sheet = Worksheets("対象シート")
Dim cnt As Long
cnt = list_sheet.Cells(Rows.Count, "C").End(xlUp).Row
Dim i As Long
Dim srcWord As String
Dim repWord As String
For i = 4 To cnt
srcWord = Trim(list_sheet.Cells(i, "C").Value)
repWord = Trim(list_sheet.Cells(i, "E").Value)
If Len(srcWord) > 0 And Len(repWord) > 0 Then
With change_sheet
myReplace Intersect(.Range("A1").CurrentRegion, .Columns("A")), srcWord, srcWord, 5 '// 青
myReplace Intersect(.Range("B1").CurrentRegion, .Columns("B")), srcWord, repWord, 3 '// 赤
End With
End If
Next
End Sub
Sub myReplace(rng As Range, srcWord, repWord, repColor) '// 色引数の追加
Dim r As Range
Dim stpos As Long
For Each r In rng
stpos = 1
Do While InStr(stpos, r.Value, srcWord) > 0
stpos = InStr(stpos, r.Value, srcWord)
r.Characters(stpos, Len(srcWord)).Delete
r.Characters(stpos, 0).Insert repWord
r.Characters(stpos, Len(repWord)).Font.ColorIndex = repColor '// 引数で色を指定
stpos = stpos + Len(repWord)
Loop
Next
End Sub
> Set beforeRng = Sheets("置換リスト").Range("c4").CurrentRegion
を
With Sheets("置換リスト")
Set beforeRng = .Range("c4", .Range("c" & Rows.Count).End(xlup))
End With
に変更してみてください。
(seiya)
>Mookさん 完璧です！！ 素敵すぎます。 ありがとうございます。
図々しくて恐縮なのですが、追加でA列を青字にして欲しい言われまして、 [r.Characters(stpos, Len(srcWord)).Font.ColorIndex = 5]を追記してみたのですが、 A,Bところどころ青と赤が混在してしまい、うまくいきません。。。 ちゃんと理解しきれていないのがばればれですが。。。
>seiyaさん ありがとうございます。 「実行時エラー'5017' アプリケーション定義またはオブジェクト定義のエラーです。」 になって、「 If .test(r.Value) Then」が黄色くなりました。 確認します。
無事に動いたようで良かったです。 色の指定を出来るように、上記のコードを変更しました。 (Mook)
問題が解決したようなので... こちらでは期待通りの結果が得られているので、これでだめならあきらめましょう。
Sub test()
Dim beforeRng As Range, afterRng As Range, r As Range
Dim myPtn() As String, myReplace() As String
Dim i As Long, n As Long
Dim m As Object, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("置換リスト")
Set beforeRng = .Range("c4", .Range("c" & Rows.Count).End(xlUp))
End With
For Each r In beforeRng.Columns(1).Cells
If (Not IsEmpty(r)) And (Not IsEmpty(r(, 3))) Then
dic(r.Value) = r(, 3).Value
End If
Next
Set beforeRng = Nothing
With Sheets("対象シート")
Set afterRng = .Range("a1", .Cells.SpecialCells(11)).Resize(, 1)
End With
With CreateObject("VBScript.RegExp")
.Global = True
For Each r In afterRng.Columns(1).Cells
.Pattern = Join$(dic.keys, "|")
If .test(r.Value) Then
ReDim myReplace(1 To .Execute(r.Value).Count), _
myPtn(1 To .Execute(r.Value).Count)
n = 0
For Each m In .Execute(r.Value)
r.Characters(m.firstindex + 1, m.Length) _
.Font.Color = vbRed
n = n + 1
myReplace(n) = dic(m.Value)
myPtn(n) = m.Value
Next
For i = 1 To n
.Pattern = myPtn(i)
If .test(r(, 2).Value) Then
r(, 2).Value = .Replace(r(, 2).Value, myReplace(i))
End If
Next
.Pattern = Join$(myReplace, "|")
For Each m In .Execute(r(, 2).Value)
r(, 2).Characters(m.firstindex + 1, m.Length) _
.Font.Color = vbRed
Next
End If
Next
End With
Set afterRng = Nothing
Set dic = Nothing
End Sub
(seiya)
>Mookさん ありがとうございます！？ そこに追記すればよいのですね、、、 勉強不足です、、 本当に助かりました！！
>seiyaさん 状況がわからない中、ありがとうございます。 やはり同じエラーになってしまいましたが、 記載していただいたコードを私も勉強してみます。
本当にありがとうございました！！
こうめさん、興味深いご質問、楽しく読ませていただきました。 横入り、すみません・・・・失礼します！
Mookさん、caiさん、seiyaさん、マクロ勉強中の私にとっても、 素晴らしいご解答、大変参考になりました♪
ひとつだけ、質問があるのですが、 新しく質問したほうがいいのかなー と思いながらの投稿・・・・ ご無礼をお許しください！ （その方がいいのであれば、ご指摘くださいませ）
Mookさんのコードの、変数などを日本語で書くとしたら、どのようになりますでしょうか？
お時間のある時で充分ですので、どうか 宜しくお願いします☆彡
いつまでも、お待ちしております。
こうめさん、Mookさん、重ね重ね、失礼をお許しください。
（村尾 加奈）
加奈さんも以前類似の処理をされたので興味を持たれたでしょうか。そういった参加は 大歓迎ですよ。マクロの変数や関数名等を日本語で書くか、英語で書くかはそれぞれの 好き好きだと思いますが、日本語の方がわかりやすいという人も多いかもしれません。
興味本位ですが、日本語化してみましたがどうでしょうか。 こうめさんもマクロの内容を把握しかねる部分があるようですから、説明も追加して みました。 (Mook)
Option Explicit
'//------------------------------------------------------------------
Sub 単語置換処理()
'//------------------------------------------------------------------
'// こっちは置換する元の文字と置換文字のリスト
Dim 置換リストWS As Worksheet
Set 置換リストWS = Worksheets("置換リスト")
'// こっちは一括置換したい対象のシート
Dim 対象データWS As Worksheet
Set 対象データWS = Worksheets("対象シート")
'// 処理データの最終行
Dim 最終行 As Long
最終行 = 置換リストWS.Cells(Rows.Count, "C").End(xlUp).Row
Dim 処理行 As Long
Dim 検索語 As String
Dim 置換語 As String
'// データ範囲は４行目から最終行までが規定
For 処理行 = 4 To 最終行
'// 一応念の検索語と置換語は Trim関数で前後のスペースを削除
検索語 = Trim(置換リストWS.Cells(処理行, "C").Value)
置換語 = Trim(置換リストWS.Cells(処理行, "E").Value)
'// 一応検索語と置換語が空でない場合のみ処理
If Len(検索語) > 0 And Len(置換語) > 0 Then
With 対象データWS
'// 検索語の着色処理：検索語と置換語を同じにすることで、文字を変えずに色だけ着ける処理としている
文字置換処理 Intersect(.Range("A1").CurrentRegion, .Columns("A")), 検索語, 検索語, 5 '// 青
'// 置換語の着色処理
文字置換処理 Intersect(.Range("B1").CurrentRegion, .Columns("B")), 検索語, 置換語, 3 '// 赤
End With
End If
Next
End Sub
'//------------------------------------------------------------------
Sub 文字置換処理(処理範囲 As Range, 検索語, 置換語, 置換文字色) '// 色引数の追加
'//------------------------------------------------------------------
Dim 処理セル As Range
Dim 検索開始位置 As Long
'// 指定範囲のセルを順番に処理
For Each 処理セル In 処理範囲
'// 検索文字列の先頭から処理
検索開始位置 = 1
Do While InStr(検索開始位置, 処理セル.Value, 検索語) > 0
'// 検索文字があった場合は、文字の位置が入る
検索開始位置 = InStr(検索開始位置, 処理セル.Value, 検索語)
'// 検索語を削除
処理セル.Characters(検索開始位置, Len(検索語)).Delete
'// 置換語を削除位置に挿入
処理セル.Characters(検索開始位置, 0).Insert 置換語
'// 挿入した置換文字列に色を着ける
処理セル.Characters(検索開始位置, Len(置換語)).Font.ColorIndex = 置換文字色 '// 引数で色を指定
'// 検索開始位置を、今処理した単語の後ろからに変更
検索開始位置 = 検索開始位置 + Len(置換語)
Loop
Next
End Sub
Mookさん、わーーーーー お忙しいのに、速攻で・・・・ ありがとうございます！
一行づつ、
しかも 塊ごとにも とっーーーーーー
・・・・ても わかりやすく説明を書いてくださって・・・・感激です！！
マクロの初心者の私には、日本語のコードが 全く別のもののように感じるほど、
素晴らしく 頭の中に入ってくるスピードが かなり違います。
いまから ゆっくり ２つのコードを並べて、
また 違いの分かる女になってきます！
貴重なお時間を ありがとうございました♪
こうめさんの質問なのに、横から 大変失礼しました。
（村尾 加奈）
私も横から 失礼します。 Mookさん 日本語コード 大変勉強になります。 解読出来ない部分がかなりありましたが 何となく解りました 参考書もこんな感じなら 初心者は、有難いですね。 ありがとうございました。 りさ
Mookさん わかりやすい、日本語の解説ありがとうございます！？ とても勉強になりました。 今回は本当に助かりました。 ありがとうございます。
(こうめ)
あらら＾＾、 意外と日本語のコードは好評でしたね。
初心者の方が戸惑うのは、文法や関数かと思っていましたが、変数の意味の理解も意外に 手間取っているということなのでしょうか。
マクロを理解するために、たまにはこういうコードも良いかもしれませんね。 すっかり こうめさんの質問から脱線してしまいましたが、楽しいきっかけをくれた 加奈さんのコメントにも感謝です＾＾。りさ さんもコメントありがとうございました。 (Mook)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.