質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.46%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Office 365

Office 365は、マイクロソフトが販売している企業向けクラウドベースのグループウエアサービス。電子メールや予定表、Webサイト構築、オンラインストレージ、ビデオ会議などビジネスで必要な機能を備えています。クラウドサービスのため、自社での専用サーバーの設置の必要がないことが特徴です。

Q&A

解決済

1回答

534閲覧

リストと一致した文字を部分一致で検索し、ヒットした文字のみ色を変更したい

tera1325153

総合スコア2

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Office 365

Office 365は、マイクロソフトが販売している企業向けクラウドベースのグループウエアサービス。電子メールや予定表、Webサイト構築、オンラインストレージ、ビデオ会議などビジネスで必要な機能を備えています。クラウドサービスのため、自社での専用サーバーの設置の必要がないことが特徴です。

0グッド

0クリップ

投稿2023/10/24 01:42

実現したいこと

ここに実現したいことを箇条書きで書いてください。

  • 「修正一覧」のA行に検索する文字のリストが作ってあります。
  • 「修正一覧」に記載した文字を、「データ一覧」に対して部分一致で検索し、ヒットした文字のみを赤文字に置換したいです。

前提

ここに質問の内容を詳しく書いてください。

・検索した文字列を含むセルの文字がすべて赤文字になってしまいます。
セルの文字すべてではなく、一致した文字のみ赤文字にしたいです。
・下記コードを流用して使用したいです。大幅なコードの変更をせずに、セルの特定の文字のみを変更する、コードの修正案を教えていただけないでしょうか?

発生している問題・エラーメッセージ

「試したこと」に記載しました

該当のソースコード

Sub yuremark_backdata() Dim 修正一覧 As Range Dim データ範囲 As Range Dim i As Long Dim wb1 As Workbook Dim ExcelApp As New Application Dim ReadFolderFullPath As String ReadFolderFullPath = "\\000.00.00.000\★活動テーマ\1件目\006_対策実施\表記ゆれ対\hyoukiyure_list.xlsx" ExcelApp.Visible = False ExcelApp.DisplayAlerts = False Set wb1 = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True) ' ワークシート「modify_ilist」を指定 Set 修正一覧 = wb1.Worksheets("modify_ilist").Range("A1").CurrentRegion ' データ範囲はアクティブシートのUsedRangeを使用 Set データ範囲 = activeSheet.UsedRange For i = 2 To 修正一覧.Rows.Count With Application.ReplaceFormat.Font.Color = 255 End With データ範囲.Replace _ What:=修正一覧.Cells(i, 1).Value, _ ReplaceFormat:=True, _ Replacement:="", _ LookAt:=xlPart Next i wb1.Close SaveChanges:=False ' ワークブックを閉じる MsgBox "表記ゆれ候補を強調しました。" End Sub

試したこと

With Application.ReplaceFormat.Font.Color = 255 End With ↓ With Application.ReplaceFormat.Characters.Font.Color = 255 End With にすると、「オブジェクトは、このプロパティまたはメソッドをサポートしていません」 と表示されます。 「Characters」 の使い方に問題があるところまでわかるのですが、どのように組み合わせたらよいかわかりません。

補足情報(FW/ツールのバージョンなど)

イメージ説明

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

ベストアンサー

For文の中だけ。
・置換を検索に変更
・該当文字があれば文字位置を取得
・文字数分の色を変更

でどうでしょうか。

2023/10/24 13:14 
If (Not (findobj Is Nothing)) Then の次行、Elseがあったのを削除しました。
適当に書いていた時点で If (findobj Is Nothing) Then で書いていた名残です…

For i = 2 To 修正一覧.Rows.Count Set findobj = データ範囲.Find(What:=修正一覧.Cells(i, 1).Value, LookAt:=xlPart) If (Not (findobj Is Nothing)) Then cStart = InStr(findobj, 修正一覧.Cells(i, 1).Value) cLen = Len(修正一覧.Cells(i, 1).Value) Cells(findobj.Cells.Row, findobj.Cells.Column).Characters(Start:=cStart, Length:=cLen).Font.Color = RGB(255, 0, 0) End If Next i

23/10/24 17:07 追記
丸ごと貼り付けておきます。
私の環境では動作しましたので、あとは動作環境でデバックしてもらうしかないかなと思います。

Sub yuremark_backdata_edit() Dim 修正一覧 As Range Dim データ範囲 As Range Dim i As Long Dim wb1 As Workbook Dim ExcelApp As New Application Dim ReadFolderFullPath As String ReadFolderFullPath = "[filePath]\hyoukiyure_list.xlsx" ExcelApp.Visible = False ExcelApp.DisplayAlerts = False Set wb1 = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True) ' ワークシート「modify_ilist」を指定 Set 修正一覧 = wb1.Worksheets("modify_ilist").Range("A1").CurrentRegion ' データ範囲はアクティブシートのUsedRangeを使用 Set データ範囲 = ActiveSheet.UsedRange For i = 2 To 修正一覧.Rows.Count Set findobj = データ範囲.Find(What:=修正一覧.Cells(i, 1).Value, LookAt:=xlPart) If (Not (findobj Is Nothing)) Then cStart = InStr(findobj, 修正一覧.Cells(i, 1).Value) cLen = Len(修正一覧.Cells(i, 1).Value) Cells(findobj.Cells.Row, findobj.Cells.Column).Characters(Start:=cStart, Length:=cLen).Font.Color = RGB(255, 0, 0) End If Next i wb1.Close SaveChanges:=False ' ワークブックを閉じる MsgBox "表記ゆれ候補を強調しました。" End Sub

投稿2023/10/24 02:39

編集2023/10/24 08:10
mdj

総合スコア220

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

tera1325153

2023/10/24 04:46

お忙しい中回答いただけて、助かります!ありがとうございます! 理解不足ですみません。 「For」から「Next i」までカット&ペーストしたのですが、「オブジェクト変数またはWith」ブロック変数が設定されていません」というエラーが出ました。 最初に下記コードを追加してみましたが、解決できていません。私は何か設定を間違えているのでしょうか Dim cStart As Long Dim cLen As Long Dim findobj As Range
mdj

2023/10/24 08:12

回答に一式を追加しましたので、ファイルパス部分のみ修正していただいて動作させてみてください。 そのうえでエラーが出るようでしたら、デバッグしてエラー箇所をご確認いただくことになるかなと思います。
tera1325153

2023/10/25 03:49

お忙しい中ありがとうございます!! 少し修正すると、思い通りに動きました!! メモ↓ Sub yuremark() Dim 修正一覧 As Range Dim データ範囲 As Range Dim i As Long Dim k As Long Dim wb1 As Workbook Dim ExcelApp As New Application Dim ReadFolderFullPath As String Dim myStr As String Dim findobj As Range Dim myFirst As Range ReadFolderFullPath = "[リンク]\hyoukiyure_list.xlsx" ExcelApp.Visible = False ExcelApp.DisplayAlerts = False Set wb1 = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True) Set 修正一覧 = wb1.Worksheets("modify_ilist").Range("A1").CurrentRegion Set データ範囲 = activeSheet.UsedRange For i = 2 To 修正一覧.Rows.Count myStr = 修正一覧.Cells(i, 1) Set findobj = データ範囲.Find(what:=修正一覧.Cells(i, 1).Value, lookat:=xlPart) If Not findobj Is Nothing Then Set myFirst = findobj GoTo 処理 Do Set findobj = データ範囲.FindNext(after:=findobj) If findobj.Address = myFirst.Address Then Exit Do GoTo 処理 処理: For k = 1 To Len(findobj) If Mid(findobj, k, Len(myStr)) = myStr Then findobj.Characters(Start:=k, Length:=Len(myStr)).Font.ColorIndex = 3 End If Next k Loop End If Next i wb1.Close SaveChanges:=False ' ワークブックを閉じる MsgBox "表記ゆれ候補を強調しました。" End Sub
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.46%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問