[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『検索文字を含む文章の検索文字のみ色を変更』（経理初心者）
下記コードにより、D3セルに入力した文字列をB5セル開始のテーブルの3列目から検索して抽出しています。
Range("B5").AutoFilter field:=3, Criteria1:="*" & Range("D3").Value & "*"
これに、さらに、D3セルに入力した文字列を、抽出するだけでなく、検索した文字列のみ赤くしたいのですが、やり方がわかりません。
教えていただけないでしょうか？
例）
D3セル＝「運用」と入力し、検索
テーブルの中の文章
この運用は、～ ←「運用」の部分のみ赤色に変える
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
なので、例えばこんな感じじゃないですか？
（対象ワードが何回も出てくるということならマズイですけど）
Sub さんぷる()
Dim MyRNG As Range, bufRNG As Range
With ActiveSheet
.Range("B5").AutoFilter field:=3, Criteria1:="*" & .Range("D3").Value & "*"
Set bufRNG = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1), .Range("D:D").SpecialCells(xlCellTypeVisible))
If Not bufRNG Is Nothing Then
For Each MyRNG In bufRNG
MyRNG.Characters(Start:=InStr(MyRNG.Value, .Range("D3").Value), Length:=Len(.Range("D3").Value)).Font.Color = vbRed
Next
End If
End With
End Sub
（もこな２） 2021/06/06(日) 13:24
Sub さんぷる2()
Dim MyRNG As Range, bufRNG As Range
Dim i As Long, tmp As Long
With ActiveSheet
.Range("B5").AutoFilter field:=3, Criteria1:="*" & .Range("D3").Value & "*"
Set bufRNG = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1), .Range("D:D").SpecialCells(xlCellTypeVisible))
If Not bufRNG Is Nothing Then
For Each MyRNG In bufRNG
For i = 1 To Len(MyRNG.Value)
tmp = InStr(i, MyRNG.Value, .Range("D3").Value)
If tmp = 0 Then Exit For
MyRNG.Characters(Start:=tmp, Length:=Len(.Range("D3").Value)).Font.Color = vbRed
i = tmp + Len(.Range("D3").Value)
Next
Next
End If
End With
End Sub
（もこな２） 2021/06/06(日) 14:10
文字の色を変えるところだけ別ルーチンにしてみるとか。。。
Option Explicit
Sub hhh()
If InStr(1, Range("a1").Value, "運用") > 0 Then
kkk Range("a1"), "運用", InStr(1, Range("a1").Value, "運用")
End If
End Sub
Sub kkk(ByVal r As Range, ByVal MyStr As String, ByVal S As Long)
r.Characters(InStr(S, r.Value, MyStr), Len(MyStr)).Font.Color = vbRed
S = InStr(S + Len(MyStr), r.Value, MyStr)
If S = 0 Then Exit Sub
kkk r, MyStr, S
End Sub
ほんとにすみません。Mainであったら渡して、なくなったら出てくる。が自然ですよぇ(^^;
Mainで変数を使いたくなかったという変なこだわりが、、、(◎_◎;)
だいぶ疲れているようです。。。＿|￣|○
（SoulMan） 2021/06/06(日) 14:52
下記コードでエラーになるみたいです
Set bufRNG = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1), .Range("D:D").SpecialCells(xlCellTypeVisible))
新しく提示していただいたコードでも同じ個所でエラーになります。
（経理初心者） 2021/06/06(日) 20:43
強いて言えば【テーブル】と表現されてますが、提示されたコードでは【オートフィルタ】なので、実はオートフィルタがうまくいっておらず、ActiveSheet.AutoFilter.Rangeの取得に失敗したとも考えられますが、それなら（オートフィルタで正しく抽出されなければ）ご自身で気づきそうですし違いますよね・・・
（もこな２） 2021/06/06(日) 21:10
お邪魔します。
さっきこちらでテストしました別にでませんけど、↓これでも
Set bufRNG = Intersect(.AutoFilter.Range, .Range("D:D").SpecialCells(xlCellTypeVisible))
これ↓でもでますか？ Set bufRNG = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1)) （SoulMan） 2021/06/06(日) 21:14
Sub さんぷる3()
Dim MyRNG As Range
Dim i As Long, tmp As Long
With ActiveSheet
For Each MyRNG In .Range("D5", .Cells(.Rows.Count, "D").End(xlUp))
For i = 1 To Len(MyRNG.Value)
tmp = InStr(i, MyRNG.Value, .Range("D3").Value)
If tmp = 0 Then Exit For
MyRNG.Characters(Start:=tmp, Length:=Len(.Range("D3").Value)).Font.Color = vbRed
i = tmp + Len(.Range("D3").Value)
Next i
Next MyRNG
End With
End Sub
（もこな２） 2021/06/06(日) 21:18
解除は下記のとおりしています
Range("D3").ClearContents
Range("B5").AutoFilter field:=3, Criteria1:="*" & Range("D3").Value & "*"
SoulMan様
ありがとうございます
提示いただいた方法でもできました！
原因はわかりませんがたすかりました。
（経理初心者） 2021/06/06(日) 21:37
（再掲）
https://www.moug.net/tech/exvba/0110016.html
全体の色を変えるにはどうするとかいてありましたか？
（実際には、「検索解除」（たぶん、オートフィルタの絞り込みを解除）というのをどうやって察知するか、そちらのほうが問題になるとおもいますが・・・）
（もこな２） 2021/06/06(日) 22:19
（経理初心者） 2021/06/06(日) 23:53
Sub あいまい検索E()
Application.ScreenUpdating = False
Dim MyRNG As Range
Dim i As Long, tmp As Long
Set MyRNG = Range("D:D").Find("D3")
If Range("E3") = "" Then
MsgBox "検索したい文字を入力してください"
ElseIf MyRNG Is Nothing Then
MsgBox "該当するものはありませんでした。"
Else
Range("B5").AutoFilter field:=4, Criteria1:="*" & Range("D3").Value & "*"
With ActiveSheet
For Each MyRNG In .Range("D6", .Cells(.Rows.Count, "D").End(xlUp))
For i = 1 To Len(MyRNG.Value)
tmp = InStr(i, MyRNG.Value, .Range("D3").Value)
If tmp = 0 Then Exit For
MyRNG.Characters(Start:=tmp,Length:=Len(.Range("D3").Value)).Font.Color = vbRed
i = tmp + Len(.Range("D3").Value)
Next i
Next MyRNG
End With
End If
Application.ScreenUpdating = True
End Sub
（経理初心者） 2021/06/07(月) 22:03
こんばんは！ 書き方は色々あると思いますし、、手前味噌で申し訳ないですけど。。。 想像力をMaxにして、、、 この AutoFilter が必要なのか？今一わかりません。必要なんでしょうね？？？多分。。。 まぁ、、それは、、それということで。。。。
Option Explicit
Sub あいまい検索E()
Dim MyRNG As Range
With ActiveSheet
If .Range("D3").Value = "" Then
MsgBox "検索したい文字を入力してください"
Exit Sub
End If
Set MyRNG = .Range("D:D").Find(.Range("D3"))
If MyRNG Is Nothing Then
MsgBox "該当するものはありませんでした。"
Exit Sub
End If
Application.ScreenUpdating = False
.Range("B5").AutoFilter field:=4, Criteria1:="*" & .Range("D3").Value & "*"
For Each MyRNG In .Range("D6", .Cells(.Rows.Count, "D").End(xlUp))
If InStr(1, MyRNG.Value, .Range("D3").Value) > 0 Then
kkk MyRNG, .Range("D3").Value, InStr(1, MyRNG.Value, .Range("D3").Value)
End If
Next MyRNG
.AutoFilterMode = False
Application.ScreenUpdating = True
End With
End Sub
Sub kkk(ByVal r As Range, ByVal MyStr As Variant, ByVal S As Long)
r.Characters(InStr(S, r.Value, MyStr), Len(MyStr)).Font.Color = vbRed
S = InStr(S + Len(MyStr) , r.Value, MyStr)
If S > 0 Then kkk r, MyStr, S
End Sub
（SoulMan） 2021/06/07(月) 22:48
r.Characters(InStr(S, r.Value, MyStr), Len(MyStr)).Font.Color = vbRed
上記のところでプロシージャの呼び出し、または引数が不正です。というふうにでてしまいます。
Sub kkk(ByVal r As Range, ByVal MyStr As String, ByVal S As Long)
r.Characters(InStr(S, r.Value, MyStr), Len(MyStr)).Font.Color = vbRed
S = InStr(S + Len(MyStr), r.Value, MyStr)
If S = 0 Then Exit Sub
kkk r, MyStr, S
End Sub
ここのところが何をしているのかさっぱりわからないです。
（経理初心者） 2021/06/07(月) 23:20
あっ、すみません もうパソコンを切っちゃったので また、あしたで良ければ おかしいなぁ、 あったら渡す なくなったら出てくる 混乱させちゃいましたね すみません （SoulMan） 2021/06/07(月) 23:30
再登場(^^; さっきこちらでテストしてみましたけど、、サンプルが悪いのか？出ませんね。。。 でも、、ちょっと変えてみました。m(__)m （SoulMan） 2021/06/07(月) 23:46
すみません。明日、見てみますので どんなサンプルでエラーが出るか書いておいてください。 おやすみなさいzzzzzzzzzzzzz （SoulMan） 2021/06/07(月) 23:59
とりあえず何点か気になるところを。
■１
↓はアクティブシートのD列全体から"D3"を探そうとしています。（D3セルの値ではありません）正しい処理（想定どおり）ですか？、
Set MyRNG = Range("D:D").Find("D3")
■２
また、Findメソッドの引数には省略すると（手動、マクロ問わずに）前回値を承継するものがあります。
したがって、Lookin、LookAtくらいは指定するようにしたほうがよいでしょう。
https://www.moug.net/tech/exvba/0150111.html
■３
さらに、上記を踏まえ↓のように修正したとしましょう。
Set MyRNG = Range("D:D").Find(What:=Range("D3").Value, LookIn:=xlValues, LookAt:=xlPart)
これは、（アクティブシートの）D列全体から、（アクティブシートの）D3セルの値を含むセルを探そうとしています。
当たり前ですが、D列全体にD3セルは含まれます。これで正しい（想定どおりの）処理になりますか？
■４
このほか、Findメソッドは【セル】を探す命令です。一方で今回の処理では、見つかったセルは使っていません。
有無を調べるだけなら、Findメソッドで検索しなくとも、ワークシート関数のCOUNTIFを使い0個であれば無いという判定ができます。
（他にもワークシート関数のMatchを使い、なければエラーになるというのを利用する手もあります）
■５
＞D3セルに入力した文字列
という設計ですよね
If Range("E3") = "" Then MsgBox "検索したい文字を入力してください"
^↑^^
正しいですか？
■６
さて、先日「検索解除」をどうやって察知するかが問題になると書きました。
思っているのとは違うかもしれませんが、例えばChangeイベントを利用してD3セルへの書き換えでマクロが発動するようにするという手もあろうかとおもいます。
※対象シートのモジュールに記述
Private Sub Worksheet_Change(ByVal Target As Range)
Dim bufRNG As Range, MyRNG As Range
Dim i As Long, tmp As Long
If Intersect(Target, Range("D3")) Is Nothing Then Exit Sub
Set bufRNG = Intersect(AutoFilter.Range, AutoFilter.Range.Offset(1), Range("D:D"))
bufRNG.Font.ColorIndex = xlAutomatic
If Range("D3").Value = "" Then
On Error Resume Next
ShowAllData
On Error GoTo 0
ElseIf WorksheetFunction.CountIf(bufRNG, "*" & Range("D3").Value & "*") = 0 Then
Range("B5").AutoFilter field:=4, Criteria1:="*" & Range("D3").Value & "*"
MsgBox "該当するものはありませんでした。"
Else
For Each MyRNG In bufRNG
For i = 1 To Len(MyRNG.Value)
tmp = InStr(i, MyRNG.Value, Range("D3").Value)
If tmp = 0 Then Exit For
MyRNG.Characters(Start:=tmp, Length:=Len(Range("D3").Value)).Font.Color = vbRed
i = tmp + Len(Range("D3").Value) - 1 '←ミスっていたので修正
Next i
Range("B5").AutoFilter field:=4, Criteria1:="*" & Range("D3").Value & "*"
Next MyRNG
End If
End Sub
（もこな２） 2021/06/08(火) 03:49
おはようございます。 もこな２ さんのコードをヒントにあってるかどうかわかりませんけど、 怪しいそうなところを直してみました。
でも、もこな２ さんの方で進めてください。 乱入、失礼しました。m(__)m （SoulMan） 2021/06/08(火) 06:12
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.