VBA

【Excel】セル内の特定の文字だけ色を変える

Excelで大量のデータを管理している場合に、特定の文字だけ色を変えて目立たせたい時があります。

例えば、ログ情報などをEXCELで管理している際に「エラー」という文言だけを目立たせたい場合です。

↓以下のような形で色を付けたい

大量にデータが存在していた場合は、1件ずつ対応するのが非常に面倒なので、自動で対応する方法を考えてみました。

セル全体の色を変えたい場合は、置換で対応

「Excel 特定の文字 色」とかで検索すると沢山出てくる方法ですが、置換を使用すると簡単に色付をすることができます。

まず、「CTRL + H」を押下して検索と置換ウィンドウを開きます。

そして、置換後の文字列の「書式」を選択して、色を変更します。この時、置換後の文字列は検索する文字列と同じ値を設定します。

実施すると以下のようになります。セル全体の色が変わってしまいますが、これで要件を満たせる場合は最もお手軽な方法です。

ユーザーが入力した文字に特定の文字があった場合、色を変える

次に、Excelに予め入力されている文字ではなく、ユーザー入力時に文字色を変更する方法を記載します。

例えば入力を禁止したい文字列がある場合に、ユーザーにわかりやすくするために有効です。

この場合は条件付き書式を使用します。

色を変えたいセルを範囲指定している状態で、ホームタブの条件付き書式をクリックします。

新しいルールを選択します。

新しい書式ルールで「数式を使用して、書式設定するセルを決定」を選び、以下の式を入力します。

=COUNTIF(A1,"*エラー*")

※上記式のA1はセルの色を変えたい範囲の左上のセルを選択します。

そして、書式ボタンで色を選択します。すると「エラー」という文言が含まれる行が赤色に変更されます。

これは置換した場合と違い、セルの値が変更されるたびに評価されます。なので前述したとおり、ユーザーの入力値をチェックしたい場合に最適です。


セル全体ではなく文字の色だけを変える

最後に、冒頭に記載した例のようにセルの値全部ではなく、セル内の特定文字の色だけを変更したい場合について記載します。

これは、EXCELの標準機能や関数では対応が難しいためVBAを使用することにしました。

作成したコードが以下となります。

Public Sub setColor()
    '検索するキーワード
    Const KEYWORD = "エラー"
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1
    
    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")
    
    With regexp
        .Pattern = KEYWORD
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961
            Next j
        Next i
    End With
    Set regResult = Nothing
    Set regexp = Nothing
End Sub

1行目の値に「エラー」という文言があれば、エラーという文言のみを赤色にしています。(CONSTで定義している部分)

正規表現でマッチさせたものをすべて赤くしているので、下記のように2回文言が出現したら、全て赤色にしています。


76 件のコメント

  • はじめまして。
    まさにやりたいことの記述が見つかり、非常に助かりました！
    ただ、記述をすべて理解できてはおりません･･･。
    For j = 0 To regResult.Count – 1
    の「-1」は何を意味していますか。
    「j=1」ではなく「j=0」から始めるのは、検索ワードが1つもないセルがありうるから、という解釈で正しいでしょうか。

    返信する

    • regResultには、セル内で検索ワードがヒットした位置などが格納されるのですが
      これを取り出すときに0から始まるというルールだからです。

      最初にヒットした位置はregResult(0).FirstIndex
      2つ目にヒットした位置はregResult(1).FirstIndex
      3つ目にヒットした位置はregResult(2).FirstIndex

      こんな感じで一つずつずれます。

      返信する

      • ご説明をありがとうございます！
        セル内で3つヒットした場合にregResult(2)を指定するには、3-1=2ということですね。
        -1のかわりに、-0にしてみたり、1を削除してみたりして試すと、次行でstopしてしまい、正しく書式置換できないならまだしもエラーになるために悩んでおりました。
        とても助かりました。
        ありがとうございました！

        返信する

  • はじめまして。ご質問よろしいでしょうか
    検索したいキーワードなのですが
    複数のキーワードを設定することはできますでしょうか
    もし複数の単語を赤くする記述がございましたらご教授いただけますでしょうか

    例えば
    B1セルに「エラー」
    B2セルに「登録」
    B3セルに「正常」

    とあり、その複数単語を同時に染めたいのですが
    いろいろやってみても、分からず相談しました

    返信する

    • 上で書いたサンプルを修正するとしたら以下のような感じですね。
      |で区切ることによって複数の単語に対応できます。

      Public Sub setColor()
      ‘検索するキーワード
      Const KEYWORD = “エラー|登録|正常”
      ‘色を塗るセルが格納されている列
      Const COL_TARGET = 2

      Dim regexp As Object
      Dim i As Long
      Dim j As Long
      Dim regResult As Object
      Set regexp = CreateObject(“VBScript.RegExp”)

      With regexp
      .Pattern = KEYWORD
      .IgnoreCase = True
      .Global = True
      ‘1行目から使用最終行を対象にする
      For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
      Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
      For j = 0 To regResult.Count – 1
      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961
      Next j
      Next i
      End With
      Set regResult = Nothing
      Set regexp = Nothing
      End Sub

      返信する

      • 2021年11月7日にヒロユキ様が回答されている、複数のキーワード（エラー、登録、正常）をB列に設定する方法を試したところ、キーワードだけでなく別部分も含め赤字となりました。
        例:セルに以下文章を入力
        エラーが出たので、登録しなおしてみた。
        ↓
        文章最後の「。」以外は全て赤字となる。

        あくまで、キーワードのみを色付けさせたいのですが、対処方法はございますでしょうか。

        返信する

        • すみません。ご指摘の通り不具合があってキーワードのみ色が変わる動きになっていませんでした。
          修正してみました。以下でいかがでしょうか。

          Public Sub setColor()
    '検索するキーワード
    Const KEYWORD = "エラー|登録|正常"
    '色を塗るセルが格納されている列
    Const COL_TARGET = 2
    
    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")
    
    With regexp
        .Pattern = KEYWORD
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                Dim val As String
                val = regResult(j).Value
                ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(val)).Font.Color = -16776961
            Next j
        Next i
    End With
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
          返信する

  • VBA（sub名：setColor）参考にさせていただきました。誠にありがとうございます。

    若干、作りをこちらで変更していますので、以下のエラーが該当しない場合は大変失礼致します。

    【実行時エラー5017　アプリケーション定義またはオブジェクト定義のエラーです。】
    キーワードに　例”（テスト)”　　”（”が全角で、”)”が半角の場合で
    19行目でエラーが発生してしまいました。
    全角と半角を逆にしても同様です。
    どちらとも全角、もしくは　どちらとも半角ではエラーとなりません。

    もし、改善方法があればお教えいただければありがたいです。

    よろしくお願い致します。

    返信する

  • VBAの正規表現の機能を使っているのですが、正規表現だと「半角括弧の前には円マークをつけなければいけない」ルールがあるので、 “（テスト\)”のようにします。
    あと、キーワードが1文字多くなってしまうので、Length:=Len(KEYWORD) – 1)に変えています。

    Public Sub setColor()
    ‘検索するキーワード
    Const KEYWORD = “（テスト\)”
    ‘色を塗るセルが格納されている列
    Const COL_TARGET = 1

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject(“VBScript.RegExp”)

    With regexp
    .Pattern = KEYWORD
    .IgnoreCase = True
    .Global = True
    ‘1行目から使用最終行を対象にする
    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
    Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
    For j = 0 To regResult.Count – 1
    ‘指定された単語があれば赤色にする
    ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD) – 1).Font.Color = -16776961
    Next j
    Next i
    End With
    Set regResult = Nothing
    Set regexp = Nothing
    End Sub

    他にも正規表現でそのまま使えない文字があり、以下サイトが参考になりました。

    https://qiita.com/katsukii/items/1c1550f064b4686c04d4

    返信する

  • ヒロユキ様

    返信と、解決のコード記載していただき、誠にありがとうございました。
    キーワードが正規表現を含むものと、含まないものの混在した複数のキーワード（配列にセットした複数ワード）での操作としている為、今回は、正規表現が含んだ”(“もしくは”)”は除いたキーワードで処理する方法に致しました。

    誠にありがとうございました。

    返信する

  • ヒロユキ様
    はじめまして
    探していたものが見つかり、参考にさせていただきました
    ありがとうございます

    特定のワードを直接入力した場合や関数でそのワードのみを返した場合はしっかりと色付けされるのですが、違うワードと特定のワードを組み合わせたものを関数で返すと、何も色付けされなくなってしまいます。

    改善方法等があればお教えいただきたいと思います。
    どうぞよろしくお願いします。

    返信する

  • ご返答、ありがとうございます

    そうですか、、
    リンク先の説明、とてもよく分かりました
    ご教示いただきありがとうございます！！

    返信する

  • VBAを使用させていただきました。大変参考になりました。
    お示しいただいたVBAは、対象の列が指定してあります。
    私の用途では対象の行を指定して文字色を変えたいのです。そのため自力で修正を試みたのですが、初心者のためうまくいきません。
    ご教授いただけないでしょうか。

    返信する

    • 記載したVBAのコードだと、COL_TARGET が何列目を対象にするかを設定しています。
      左から２列目を対象にしたいときは「Const COL_TARGET = 1」の部分を「Const COL_TARGET = 2」に変更すればいけると思います。
      もし固定した列ではなくて、毎回入力で変更したい場合は以下のような感じですかね

      Public Sub setColor()
      ‘検索するキーワード
      Const KEYWORD = “エラー”

      COL_TARGET = InputBox(“色を塗る列を指定してください”)
      If COL_TARGET = “” Then
      ‘キャンセルされた
      Exit Sub
      ElseIf IsNumeric(COL_TARGET) Then
      COL_TARGET = CInt(COL_TARGET)
      Else
      COL_TARGET = Range(COL_TARGET & “1”).column
      End If

      Dim regexp As Object
      Dim i As Long
      Dim j As Long
      Dim regResult As Object
      Set regexp = CreateObject(“VBScript.RegExp”)

      With regexp
      .Pattern = KEYWORD
      .IgnoreCase = True
      .Global = True
      ‘1行目から使用最終行を対象にする
      For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).row
      Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
      For j = 0 To regResult.Count – 1
      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961
      Next j
      Next i
      End With
      Set regResult = Nothing
      Set regexp = Nothing
      End Sub

      返信する

  • ヒロユキ様、早速ありがとうございます。
    私の書き方が不十分でした。申し訳ありません。
    私の用途では、ある指定の行のみがが、色付けの対象なのです。
    そのため、1行目から使用最終行を対象にするのではなく、1「列」目から使用最終「列」を対象にする方法を求めて色々改変しております。

    返信する

    • 「対象の行」と書いてくれているのに、勘違いしましたね。。。
      行指定だと以下のような感じになると思います。

      Public Sub setColor()
      ‘検索するキーワード
      Const KEYWORD = “エラー”
      ‘色を塗るセルが格納されている行
      Const ROW_TARGET = 1

      Dim regexp As Object
      Dim i As Long
      Dim j As Long
      Dim regResult As Object
      Set regexp = CreateObject(“VBScript.RegExp”)

      With regexp
      .Pattern = KEYWORD
      .IgnoreCase = True
      .Global = True
      ‘1列目から使用最終列を対象にする
      For i = 1 To ActiveSheet.Cells(ROW_TARGET, Columns.Count).End(xlToLeft).column
      Set regResult = .Execute(ActiveSheet.Cells(ROW_TARGET, i))
      For j = 0 To regResult.Count – 1
      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(ROW_TARGET, i).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961
      Next j
      Next i
      End With
      Set regResult = Nothing
      Set regexp = Nothing
      End Sub

      返信する

  • ありがとうございます。
    職場に行って試してみたところ、バッチリできました。
    私のものは、‘1列目から使用最終列を対象にする　の下に書いているカッコ内のROW_TARGETを下のようにカッコ内の後半に書いていたためうまくいかなかったことが分かりました。
    文法の難しさを感じましたが、違いが分かると面白いですね。
    本当にありがとうございました。

    For i = 1 To ActiveSheet.Cells(Columns.Count ,ROW_TARGET).End(xlToLeft).Column
    Set regResult = .Execute(ActiveSheet.Cells(i,ROW_TARGET))
    ActiveSheet.Cells(i,ROW_TARGET).Characters(Start:=regResult(j).FirstIndex + 1,

    返信する

  • VBAを使用させていただきました。　非常に参考になりました。
    また質問なのですが、このVBAは特定の文字（VBA内で指定した文字）となっていますが例えば、B列を指定してB列にあるすべての文字列と一致する、違う列にある文字の色を変えることはできるのでしょうか。
    　　　　　　　（表現がわかりずらく申し訳ございません。）
    大変お手数ですが、ご教授いただけないでしょうか。

    返信する

  • B列にキーワードを何個か書いて、それを全て処理させる感じですかね。
    それであれば以下でできるかと思います。
    コメント欄スペース使えなくしているので見づらいですが…

    Public Sub setColor()
    ‘キーワードが格納されている列(2列目)
    Const COL_KEYWORD = 2

    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_KEYWORD).End(xlUp).Row
    ‘検索するキーワード
    Dim keyword As String
    keyword = ActiveSheet.Cells(i, COL_KEYWORD).Value
    Call setColorMain(keyword)
    Next i
    End Sub

    Private Sub setColorMain(keyword As String)
    ‘色を塗るセルが格納されている列
    Const COL_TARGET = 1

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject(“VBScript.RegExp”)

    With regexp
    .Pattern = keyword
    .IgnoreCase = True
    .Global = True
    ‘1行目から使用最終行を対象にする
    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
    Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
    For j = 0 To regResult.Count – 1
    ‘指定された単語があれば赤色にする
    ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(keyword)).Font.Color = -16776961
    Next j
    Next i
    End With
    Set regResult = Nothing
    Set regexp = Nothing
    End Sub

    返信する

    • B列に幾つかのキーワードを入れて
      A列の文字に色を塗る方法を知りたいのですが
      それは
      2022年3月30日 9:05 PM
      に書かれている方法でよろしいでしょうか？

      そのまま実行しようとすると
      Public Sub setColor()
      ここでエラーが出てしまうのですが、どこを修正すればよろしいでしょうか

      返信する

      • エラーがあったとのこと、すみません。
        他のコメントで頂いたバグも修正したバージョンで再作成してみました。
        こちらでどうでしょうか。

        Const COL_KEYWORD = 2
        ↑この値を変更することでキーワードの列を変更できるようにしています。現在は２列目(B)を指定しています。

        Public Sub setColor()
    'キーワードが格納されている列
    Const COL_KEYWORD = 2
    
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1
    
    Dim keyword As String
    Dim i As Long
    
    '２列目の各セルをループ
    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_KEYWORD).End(xlUp).Row
        Dim word As String
        word = ActiveSheet.Cells(i, COL_KEYWORD).Value
        If word <> "" Then
            If keyword = "" Then
                keyword = word
            Else
                keyword = keyword & "|" & word
            End If
        End If
    Next i
    
    If keyword = "" Then
        'キーワードが設定されていないエラー
        MsgBox "キーワードが取得できませんでした"
        Exit Sub
    End If
    
    Dim regexp As Object
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")
    
    With regexp
        .Pattern = keyword
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                Dim val As String
                val = regResult(j).Value
                ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(val)).Font.Color = -16776961
            Next j
        Next i
    End With
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
        返信する

  • ご回答ありがとうございました。
    お教えいただいた方法を会社で試したところ無事できました。
    大変助かりました！！ありがとうございました。

    返信する

  • キーワードを指定するとキーワードより後ろがすべて赤色に表示されます。
    キーワードで指定した文字のみを赤くしたいのですがどうしたらいいでしょうか。
    スクリプトはコピペで行いキーワードの指定のみ変更を加えて他は変更を加えていません。

    返信する

    • 自分のExcel（Office365）だと書いてあるスクリプトで指定した文字だけ赤くなっているんですよね。
      Excelのバージョンで関数の動きが違うときもあるので、それかもしれないですが、再現しないのでちょっとわかりそうにないです＞＜

      文字数を指定しているのは以下の部分なのですが
      Lengthの値と同じ文字数を赤くしているので、Lengthの値を数値で指定すれば行けるかもしれないです。例えばキーワードが4文字なら以下のように4を指定します。

      （変更前）
      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961

      ↓

      （変更後）
      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=4).Font.Color = -16776961

      返信する

  • お世話になります。
    1列目だけを変換：Const COL_TARGET = 1
    1行目だけを変換：Const ROW_TARGET = 1
    のご教授をいただいておりますが、行列全部(シート全部)のセル対象を変換する場合、
    簡単な記述方法は御座いますでしょうか？やはりFor分で回さないとダメでしょうか？
    よろしくお願いいたします。

    返信する

    • 結局ループはさせてるのですが、個人的には以下のようにFor Eachを使うのがスマートな書き方がします。
      Const SHEET_TARGETで指定しているワークシートで使用しているセルをループさせています。

      Public Sub setColor()
      ‘検索するキーワード
      Const KEYWORD = “エラー”
      ‘色を塗るセルが格納されているシート名
      Const SHEET_TARGET = “Sheet1”

      Dim regexp As Object
      Dim i As Long
      Dim j As Long
      Dim regResult As Object
      Set regexp = CreateObject(“VBScript.RegExp”)

      Dim sh As Worksheet
      Set sh = ThisWorkbook.Worksheets(SHEET_TARGET)

      With regexp
      .Pattern = KEYWORD
      .IgnoreCase = True
      .Global = True
      For Each cell In sh.UsedRange
      Set regResult = .Execute(cell)
      For j = 0 To regResult.Count – 1
      ‘指定された単語があれば赤色にする
      cell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961
      Next j
      Next cell
      End With
      Set regResult = Nothing
      Set regexp = Nothing
      End Sub

      返信する

  • はじめまして。
    初心者質問で申し訳無いのですが、
    ‘検索するキーワード
    Const KEYWORD = “エラー”
    この部分についてで今はエラーのみですが文字色の指定をエラーと何かと言う風に2つ以上の複数にする事は可能ですか？
    教えて頂けると幸いです。

    返信する

    • 以下でどうでしょうか。例として”正常”or”エラー”を検索します。
      「Const KEYWORD = “エラー|正常”」の部分の縦線が文字の区切りになります。

      Public Sub setColor()
      ‘検索するキーワード
      Const KEYWORD = “エラー|正常”
      ‘色を塗るセルが格納されている列
      Const COL_TARGET = 1

      Dim regexp As Object
      Dim i As Long
      Dim j As Long
      Dim regResult As Object
      Set regexp = CreateObject(“VBScript.RegExp”)

      With regexp
      .Pattern = KEYWORD
      .IgnoreCase = True
      .Global = True
      ‘1行目から使用最終行を対象にする
      For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
      Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
      For j = 0 To regResult.Count – 1
      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = -16776961
      Next j
      Next i
      End With
      Set regResult = Nothing
      Set regexp = Nothing
      End Sub

      返信する

  • はじめまして、VBA非常に参考になりました。
    質問なのですが特定のセル内の特定文字の色だけを変えたいのですがその場合はどのようにしたら良いでしょうか？
    例えば、A5セルだけの特定の文字だけ色を変えたいといった感じです。
    VBA初心者なので難しくてわからなかったのでご教授の程お願いします。

    返信する

    • コメント欄でもVBAソース見やすく貼る方法確立した！！

      本題ですが、以下ではどうでしょうか。
      Const TARGET = “A5″というところで対象のセルを指定しています。

      Public Sub setColor()
    '検索するキーワード
    Const KEYWORD = "エラー"
    '色を塗るセル
    Const TARGET = "A5"

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")

    With regexp
        .Pattern = KEYWORD
        .IgnoreCase = True
        .Global = True
        Set regResult = .Execute(ActiveSheet.Range(TARGET))
        For j = 0 To regResult.Count - 1
            '指定された単語があれば赤色にする
            ActiveSheet.Range(TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = -16776961
        Next j
    End With
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
      返信する

  • はじめまして、エクセルのセルの一部の文字列の色を変える方法を探していたところこのページにたどりつきました。もしご存じだったらご教授いただきたいのですが…
    次のような表で

    　　A列 　 　B列
    1　エラー　　これはエラーです。
    2　正常　　　今日は正常です。
    3　問題　　　たくさんの問題があります。

    B列の各セルの中の文について、すぐ左のA列に設定したキーワードと同じ文字列だけを赤色にしたいのですが、ここで紹介されている内容を応用することで実現可能だったりしますでしょうか？

    返信する

    • 列指定があると関数でなんとかしたくなるけどVBAしか思いつかないですね。。。
      VBAならこんな感じでどうでしょうか。

      Public Sub setColor()
    'キーワードがある列
    Const KEYWORD_COLUMN As String = "A"
    '色を塗る列
    Const TARGET_COLUMN As String = "B"
    '開始行 1行目からスタート
    Const START_ROW As Long = 1
    '現在のシートを対象にする
    Dim sh As Worksheet
    Set sh = ThisWorkbook.ActiveSheet
    
    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")
    
    Dim row As Long
    For row = START_ROW To sh.Cells(Rows.Count, convertToColumnNum(KEYWORD_COLUMN)).End(xlUp).row
        Dim targetCell As Range
        Set targetCell = sh.Cells(row, convertToColumnNum(TARGET_COLUMN))
        Dim keywordCell As Range
        Set keywordCell = sh.Cells(row, convertToColumnNum(KEYWORD_COLUMN))
        
        With regexp
            .Pattern = keywordCell.Value
            .IgnoreCase = True
            .Global = True
            Set regResult = .Execute(targetCell)
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = -16776961
            Next j
        End With
    Next row
    

    Set regResult = Nothing
    Set regexp = Nothing
End Sub

'列のアルファベットを数値に変換する　例)A→1に変換する
Function convertToColumnNum(ByVal address As String) As Integer
    convertToColumnNum = Columns(address).Column
End Function
      返信する

      • さっそくありがとうございました。さっそく試させていただいたところ、見事に部分的に色を変えることが出来ました。もう何て言ったらいいか、手作業で数日以上かかるような作業を一瞬でできるようになったので、感謝の言葉しかありません。
        VBAのすごさとそれをあやつるヒロユキ様の見事なスキルを見せつけられた気分でした。

        返信する

  • はじめまして
    Sheet1とSheet2に同じデータを貼り付けて（A列からC列は別だが、D列以降は同じ）、Sheet1のセル内の1部の文字を変更した場合、その文字だけ色を変えたいのですが、ご教授いただけますでしょうか？

    返信する

    • D列以降は最初は同じ状態だけど、変更されるので変更されたら色を付けるということですよね。（A～C列は違うので無視）

      文字の差分は難しくて完全に判別する方法ない気もするのですが、自分なりに考えて作ってみました。
      うまくいかないケースもあるかもしれないです。。。

      下記コードをSheet1のコードに貼ると動くと思います。
      説明が下手でうまく伝わるかわからないので、サンプルで作ったEXCELもアップロードしておきます。

      サンプルファイル

      '比較対象のワークシート
Private Const TEMPLATE_SH_NAME = "Sheet2"
'比較対象の開始列 この列以降にある列の場合比較を行う
Private Const START_COLUMN = "D"

'値が変更されたときに発生するイベント
Private Sub Worksheet_Change(ByVal target As Range)
    For Each cell In target
        If cell.Column >= convertToColumnNum(START_COLUMN) And cell.Value <> "" Then
            'セルがD列以降だったら処理を行う
            Call compareMain(cell)
        End If
    Next cell
End Sub

'列のアルファベットを数値に変換する　例)A→1に変換する
Private Function convertToColumnNum(ByVal address As String) As Integer
    convertToColumnNum = Columns(address).Column
End Function

'メイン処理
Private Sub compareMain(target As Variant)
    Dim compare As Range
    '比較対象を取得
    Set compare = ThisWorkbook.Worksheets(TEMPLATE_SH_NAME).Cells(target.Row, target.Column)
    
    'まず黒くする
    Call toBlack(target)
    Call toBlack(compare)
    
    '対象セルの値を取得
    Dim targetStr As String: targetStr = target.Value
    Dim compareStr As String: compareStr = compare.Value
    
    If targetStr = compareStr Or targetStr = "" Or compareStr = "" Then
        '全く同じか空白なら終了
        Exit Sub
    End If
    
    '確認済みの文字数
    Dim tCount As Long: tCount = 0
    Dim cCount As Long: cCount = 0
    
    '確認対象の文字
    Dim tFig As String: tFig = ""
    Dim cFig As String: cFig = ""
    
    '最初の一文字を取得
    hasNext = progress(targetStr, tCount, tFig)
    hasNext = progress(compareStr, cCount, cFig)
    
    While hasNext = True
        Debug.Print (tFig)
        Debug.Print (cFig)
        '文字を比較して不一致なら赤くする
        If compareAndToRed(target, tFig, tCount, cFig) Then
            '一致していたなら両方進める
            hasNext = progress(targetStr, tCount, tFig)
            hasNext = progress(compareStr, cCount, cFig)
        Else
            Dim tRemain As Long: tRemain = getRemaining(targetStr, tCount)
            Dim cRemain As Long: cRemain = getRemaining(compareStr, cCount)
            '不一致なら残りが多い方を進める
            If tRemain > cRemain Then
                hasNext = progress(targetStr, tCount, tFig)
            Else
                hasNext = progress(compareStr, cCount, cFig)
            End If
        End If
    Wend
    
    '最後の文字を比較
    Call compareAndToRed(target, tFig, tCount, cFig)
End Sub

'文字を比較して不一致なら赤くする
Private Function compareAndToRed(target As Variant, tFig As String, tCount As Long, cFig As String) As Boolean
    If tFig <> cFig Then
        target.Characters(Start:=tCount, Length:=1).Font.Color = vbRed
        compareAndToRed = False
    Else
        compareAndToRed = True
    End If
End Function


'対象の文字を黒くする
Private Sub toBlack(target As Variant)
    With target
        .Font.Color = vbBlack
    End With
End Sub

'確認対象の文字列を進める
Private Function progress(ByRef target, ByRef count, ByRef fig) As Boolean
    count = count + 1
    fig = Mid(target, count, 1)
    If count = Len(target) Then
        '文字を最後まで検索しているならFalseを返す
        progress = False
    Else
        progress = True
    End If
End Function

'残りの文字数を取得する
Private Function getRemaining(target As String, count As Long) As Long
    getRemaining = Len(target) - count
End Function
      返信する

  • はじめまして。
    VBA初心者で恐縮ですが、設定に悩んでいることがありいくつか質問をさせていただきたいです。下記長文となりますが、ご対応いただけますと幸甚です。

    状況）
    sheet1のデータを数式にてsheet2に表示しています。
    sheet1にてセル内の特定の文字のみ色を設定しているのですが、sheet2にも同じように文字色を変更したいと思っています。
    ですが、数式や条件設定では上記の内容は実行出来ないので、sheet2を開いた際に実行されるようなマクロを設定したいと思いました。
    ヒロユキ様の各種回答を参考にさせていただき、マクロ設定を組んでみたのですが上手く実行出来ず、悩んでおります。

    教えて頂きたいこと）
    ①特定のシートを開いた際に実行されるような内容を一緒に組むことは可能でしょうか。

    ②文字色を変更したいキーワードがいくつかあるのですが、｜にて区切る旨は把握できたのですが、こちら文字数が各種異なっていても問題ないでしょうか。また※もキーワードに含んでも問題ない文字でしょうか。

    ③　②の内容に付随するかもしれませんが、以前他の方への回答の中で
    【キーワードが1文字多くなってしまうので、Length:=Len(KEYWORD) – 1)に変えています。】という内容がありましたが、
    キーワードの文字数が異なる場合は、どのように設定するのが良いでしょうか。

    長文となってしまい申し訳ございません。

    よろしくお願いいたします。

    返信する

  • 繰り返し申し訳ございません。上記匿名の者です。
    質問に漏れがありましたので、追走させていただきました。

    状況）に説明させていただきましたが、
    別sheetデータを数式にて反映させている場合、特定のキーワードを文字列にて指定しようとすると、こちらのVBAでは反映させることは出来ないでしょうか。

    これが根本的問題でした…

    返信する

    • 試してみたのですが、数式の場合は１文字でも他の色にしようとすると、全部その色に変わってしまいました。
      もしかしたら回避する方法があるのかもですが、自分の知識だと無理そうです。

      ここが重要なところだと思うので、もうアウトな気がしますが、一応ほかは実現可能だと思います。

      ＞>①特定のシートを開いた際に実行されるような内容を一緒に組むことは可能でしょうか

      これは、Sheet2のコードにWorksheet_Activateという関数を作ることで実現できます。（下記画像のところです。）
      Sheet2を開いたときにWorksheet_Activateに記載した処理が実行されます。
      ※余談ですがVBAを実行するとUnDo（ctrl + Z）で戻せなくなるので個人的には自動実行はできる限りやらないですね。

      ＞②文字色を変更したいキーワードがいくつかあるのですが、｜にて区切る旨は把握できたのですが、こちら文字数が各種異なっていても問題ないでしょうか。

      Length:=regResult(j).Lengthの形にすればいけました。
      前述の通り数式だと無理そうなので、一旦文字列に直してやってみました。

      Option Explicit

Private Sub Worksheet_Activate()
    '検索するキーワード
    Const KEYWORD = "ab|あいう"
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")

    With regexp
        .Pattern = KEYWORD
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                Dim targetCell As Object
                Set targetCell = ActiveSheet.Cells(i, COL_TARGET)
                '数式を文字列になおす
                If targetCell.HasFormula Then
                    targetCell.Value = "'" & targetCell(i, COL_TARGET).Value
                End If
                targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = vbRed
            Next j
        Next i
    End With
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
      返信する

  • 突然のご連絡恐れ入ります。
    VBAで赤色に変更されることは理解いたしました。
    では、赤色ではなくその他の色に変更した際はどのように修正すればよろしいでしょうか。
    ド素人の質問で大変恐縮ではございますが、ご確認の程よろしくお願いいたします。

    返信する

    • ブログ記事に載せたサンプルの以下コードで色を指定しているので、この値を変更します。

      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961

      ※自分の書いたコードが良くなかったのですが、「-16776961」は赤を示しています。「-16776961」ではなく「vbRed」と書くこともできます。

      例えば、青い色にする場合は以下になります。
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = vbBlue

      赤紫（マゼンタ）にする場合は以下になります
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = vbMagenta

      返信する

  • 質問です。
    論文作成者リストから、職員全員の氏名を色分けするやり方を知りたいのですが、VBAの仕組みが素人で、どこにどれを当てはめて良いかがわかりません。
    細かく説明していただくことはできますか？

    返信する

    • まずVBAで特定の文字だけを太字にするのはできそうにない感じがしました
      なのでセル全体を太字にする場合で考えたのですが
      論文作成者リストが1列目、職員の名前が「田中太郎、佐藤次郎」の場合は以下コードになります。
      コメントでコードの説明を入れてみました。

      Public Sub setBold()
    '職員全員の名前(カンマで区切って指定する)
    Const KEYWORD = "田中太郎,佐藤次郎"
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1

    '処理を行う行番号を格納する変数
    Dim i As Long

    '色を塗るセルが存在するシート
    Dim sh As Worksheet
    Set sh = ActiveSheet    '現在開いているシートを対象とする
    'シート名を指定したい場合は set sh = worksheets("Sheet1")とする（Sheet1がシート名）
    
    '1行目から最終行まで繰り返し処理を行う 例えば最終行が10の場合は、iが1～10で変化する
    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
        '職員全員の名前をカンマ区切りから配列に変換する ※splitでカンマ区切りの文字列を配列に変換できる
        Dim keywordList() As String
        keywordList = Split(KEYWORD, ",")
        
        '職員の名前を1つずつ処理する、shokuinという変数に職員の名前が順番に格納される
        For Each shokuin In keywordList
            '職員に一致するかどうかを判定 ※sh.Cells(x, y).Valueでx行目、y列目のセルの値を取得する
            If InStr(sh.Cells(i, COL_TARGET).Value, shokuin) > 0 Then
                '含まれる場合、太字にする ※.Font.Boldで太字にする
                sh.Cells(i, COL_TARGET).Font.Bold = True
            End If
        Next shokuin
    Next i
End Sub
      返信する

      • やりたいことと違うかもしれないですが、
        もし論文作成者リストのセルに名前がズバリ入っていて、職員かどうかを見分けたいだけなら自分ならVBAを使わずにExcel関数を使いますね。

        A列が論文作成者リストでC列が職員の場合に、A1を検査するには以下を使います。

        =IF(COUNTIF(C:C,A2),”職員”,”職員以外”)

        返信する

        • ありがとうございます。
          一つのセルに、ローマ字表記の論文作成者の名前が何十人と記載されている中、職員の名前をさがし太文字にする作業なんです。
          目視でやっているため、ミスが多くて、回避できる方法を探しています。

          返信する

          • 以前コメントで太文字はできなさそうと記載してしまったのですが、試すと太文字にすることはできました。
            もし職員全員の名前が固定のようでしたら、以下のような感じではどうでしょうか。
            KEYWORDに職員の名前をカンマ区切りで指定します。
            現在選択中のセルを対象にして処理を行います。

            Public Sub setBold()
    '論文作成者の名前(カンマで区切る)
    Const KEYWORD = "Taro Tanaka,Jiro Sato,Saburo Suzuki"
    
    '色を塗るセルが格納されている列(現在選択中のセルをターゲットにする)
    Dim target As Range
    Set target = Selection
    
    '名前を分割して変数に格納
    Dim keys() As String
    keys = Split(KEYWORD, ",")
    
    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")
    
    '対象セルをループさせる
    For Each targetCell In target
        '処理する前に太字をやめる
        targetCell.Font.Bold = False
    
         '名前をループさせる
        For Each Key In keys
            With regexp
                .Pattern = Key & "|" & Replace(Key, " ", "") '念のためスペースなしバージョンでも確認
                .IgnoreCase = True '大文字小文字を区別しない
                .Global = True
                Set regResult = .Execute(targetCell)
                For j = 0 To regResult.Count - 1
                    '指定された単語があれば太字にする
                    targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(Key)).Font.Bold = True
                Next j
            End With
            
        Next Key
    Next targetCell
    
    Set regResult = Nothing
    Set regexp = Nothing
End Sub

  • はじめまして。
    質問させていただきます。
    同じセルに、●●、▲▲、◾️◾️の単語があり、
    ●●は赤色、▲▲は青色、◾️◾️は緑色にしたい場合はどのようにしたらよいでしょうか？
    ご教示のほどよろしくお願いいたします。

    返信する

    • 以下のようではどうでしょうか。
      Const KEYWORD1に●●、Const KEYWORD2に▲▲、Const KEYWORD3に◾️◾️を設定する感じです。

      ちょっと力技ですが、3色くらいなら問題なさそうなので単純に色塗り処理を3回繰り返してます。

      色についてですが、セルのfont.colorにvb〇〇と記載することで色設定が可能です。
      ソース内ではvbRed、vbBlue、vbGreenを使っています。
      他にvbYellow、vbMagenta、vbCyanなどいろいろあります。

      Public Sub setColor()
    'キーワード1
    Const KEYWORD1 = "エラー"
    'キーワード1に該当する場合の色
    Const KEYWORD1_COLOR = vbRed
    
    'キーワード1の検索を準備
    Dim regexp1 As Object
    Set regexp1 = getRegExpObj(KEYWORD1)
    
    'キーワード2
    Const KEYWORD2 = "正常"
    'キーワード2に該当する場合の色
    Const KEYWORD2_COLOR = vbBlue
    
    'キーワード2の検索を準備
    Dim regexp2 As Object
    Set regexp2 = getRegExpObj(KEYWORD2)
    
    'キーワード3
    Const KEYWORD3 = "不明"
    'キーワード3に該当する場合の色
    Const KEYWORD3_COLOR = vbGreen
    
    'キーワード3の検索を準備
    Dim regexp3 As Object
    Set regexp3 = getRegExpObj(KEYWORD3)
    
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1
    
    Dim i As Long
    Dim j As Long
    
    
    '1行目から使用最終行を対象にする
    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
        'キーワード1の色塗り処理
        Call doSearch(ActiveSheet.Cells(i, COL_TARGET), regexp1, KEYWORD1_COLOR, KEYWORD1)
        'キーワード2の色塗り処理
        Call doSearch(ActiveSheet.Cells(i, COL_TARGET), regexp2, KEYWORD2_COLOR, KEYWORD2)
        'キーワード3の色塗り処理
        Call doSearch(ActiveSheet.Cells(i, COL_TARGET), regexp3, KEYWORD3_COLOR, KEYWORD3)
    Next i
End Sub

'検索に使用するVBScript.RegExpを作成する
Private Function getRegExpObj(keyword As String) As Object
    Set getRegExpObj = CreateObject("VBScript.RegExp")
    With getRegExpObj
        .Pattern = keyword
        .IgnoreCase = True
        .Global = True
    End With
End Function

'検索を実行して、その結果によって色塗りを行う
Private Sub doSearch(cell As Object, regExp As Object, color As Long, keyword As String)
    With regExp
        Dim regResult As Object
        Set regResult = .execute(cell)
        For j = 0 To regResult.Count - 1
            '指定された単語があれば色をぬる
            cell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(keyword)).Font.color = color
        Next j
    End With
End Sub
      返信する

      • ありがとうございます。
        これで事務作業が時短になります！
        もう一つ質問よろしいでしょうか。
        紫にするにはどのように記載すればよいでしょうか。
        よろしくお願いいたします。

        返信する

        • 紫はvb〇〇という定数がないのですよね。。。
          そこで自由に色を指定できるコードにしてみました。
          例として１つ目のキーワードを紫、２つ目をピンク、３つ目を緑にしてます。

          紫を指定しているのは以下コードです。
          KEYWORD1_COLOR = getRBG(128, 0, 128) ‘紫 = 128, 0, 128

          getRBG関数に渡す数値を0～255の間で変えることで色が変わります。
          1つ目の数値が赤、2つ目の数値が青、3つ目の数値が緑の強さを表しています。
          なので仮に真っ赤にするには、255,0,０になります。

          代表的な色を作るには、数値をどうしたらいいかは以下サイトが参考になりました。例えばオレンジなら255,165,0みたいです。
          https://itsakura.com/html-color-codes

          Public Sub setColor()
    'キーワード1
    Const KEYWORD1 = "エラー"
    'キーワード1に該当する場合の色
    Dim KEYWORD1_COLOR As Long
    KEYWORD1_COLOR = getRBG(128, 0, 128) '紫 = 128, 0, 128
    
    'キーワード1の検索を準備
    Dim regexp1 As Object
    Set regexp1 = getRegExpObj(KEYWORD1)
    
    'キーワード2
    Const KEYWORD2 = "正常"
    'キーワード2に該当する場合の色
    Dim KEYWORD2_COLOR As Long
    KEYWORD2_COLOR = getRBG(255, 20, 147) 'ピンク = 255, 20, 147
    
    'キーワード2の検索を準備
    Dim regexp2 As Object
    Set regexp2 = getRegExpObj(KEYWORD2)
    
    'キーワード3
    Const KEYWORD3 = "不明"
    'キーワード3に該当する場合の色
    Dim KEYWORD3_COLOR As Long
    KEYWORD3_COLOR = getRBG(0, 128, 0)  '緑 = 0, 128, 0
    
    'キーワード3の検索を準備
    Dim regexp3 As Object
    Set regexp3 = getRegExpObj(KEYWORD3)
    
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1
    
    Dim i As Long
    Dim j As Long
    
    
    '1行目から使用最終行を対象にする
    For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
        'キーワード1の色塗り処理
        Call doSearch(ActiveSheet.Cells(i, COL_TARGET), regexp1, KEYWORD1_COLOR, KEYWORD1)
        'キーワード2の色塗り処理
        Call doSearch(ActiveSheet.Cells(i, COL_TARGET), regexp2, KEYWORD2_COLOR, KEYWORD2)
        'キーワード3の色塗り処理
        Call doSearch(ActiveSheet.Cells(i, COL_TARGET), regexp3, KEYWORD3_COLOR, KEYWORD3)
    Next i
End Sub

'検索に使用するVBScript.RegExpを作成する
Private Function getRegExpObj(keyword As String) As Object
    Set getRegExpObj = CreateObject("VBScript.RegExp")
    With getRegExpObj
        .Pattern = keyword
        .IgnoreCase = True
        .Global = True
    End With
End Function

'検索を実行して、その結果によって色塗りを行う
Private Sub doSearch(cell As Object, regExp As Object, color As Long, keyword As String)
    With regExp
        Dim regResult As Object
        Set regResult = .Execute(cell)
        For j = 0 To regResult.Count - 1
            '指定された単語があれば色をぬる
            cell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(keyword)).Font.color = color
        Next j
    End With
End Sub

Private Function getRBG(r As Long, b As Long, g As Long)
    getRBG = 65536 * g + 256 * b + r
End Function
          返信する

  • ありがとうございます。
    とても勉強になりました。
    これからも使わせていただきたいと思います。

    返信する

  • はじめまして。
    VBA初心者で恐縮ですが質問させて下さい。

    VBAを使用させて頂き指定の文字だけのセルは文字の色が変更されるのですが
    文字列の中に指定の文字が含まれる場合には色が変更されません
    また変更されたものの後ろに違う文字を入れればその文字も色が変わってしまいます。

    Excel365を使用しています。

    ご教授頂けましたら幸いです。

    返信する

    • 自分の環境ですと、文字列の中に指定の文字が含まれる場合も色変更できました。
      記事に掲載したVBAプログラムですが、下記の「Length=」の部分で何も自分色を変えるかを指定しています。
      （Len(KEYWORD)で指定した文字列の長さを取得していて、その数値をLengthに設定しています。）

      ‘指定された単語があれば赤色にする
      ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = -16776961

      見当違いでしたらすみませんが、この部分が怪しいので確認してみてください。
      また後ろに違う文字を入れると、Excelが勝手にその文字の色も変えてしまうみたいです。おそらく便利に使うための機能だと思うのですが、ちょっと回避策は分からなかったです。。。
      あまり力になれない返信ですみません。

      返信する

      • ヒロユキ様ご返信ありがとうございます。
        やはりキーワードのみのセルしか色が変わってくれないようです。

        わざわざご返信いただけたのに解決できずに申し訳ございません。

        返信する

  • はじめまして。
    VBAについて全くの初心者なので、素人ながらに質問させてください。
    一つのセル内に複数の単語があり、同じようなセルが縦に10行ほど（例：C5～C14）並んでいる表を業務で扱っています。その表から一つの単語を探すために毎度Ctrl＋Fで検索をかけているのですが、1セルに1単語というような作りではないため、当たり前ですが、単語が含まれているセルを検索結果扱いとされてしまいます。検索結果の単語のみを赤文字に色付けするようなことをしたいのですが、できますでしょうか？

    返信する

    • 以下のコードでC5～C14の特定の単語のみを赤字に変更できました。
      範囲をD5～D14に変える場合は、TARGET_RANGE = “D5:D14″にします。
      やりたいことと違ってたらすみません＞＜

      Private Sub Worksheet_Activate()
    '検索するキーワード(複数存在する場合は|で区切る　例 Const KEYWORD = "ab|あいう")
    Const KEYWORD = "あいう"
    '色を塗るセルが格納されている範囲
    Const TARGET_RANGE = "C5:C14"

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")

    Dim r As range
    Set r = ActiveSheet.range(TARGET_RANGE)

    With regexp
        .Pattern = KEYWORD
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For Each c In r
            Set regResult = .Execute(c)
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                Dim targetCell As Object
                Set targetCell = c
                targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = vbRed
            Next j
        Next
    End With
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
      返信する

      • お返事ありがとうございます。
        上記のコードなのですが、試してみたところ検索前から全単語が常時赤文字で表示
        されるようになりました。検索前（通常時）→黒文字のまま、Ctrl+Fで検索→検索に
        引っかかった単語のみを赤文字、といった使用は可能でしょうか？

        返信する

        • なるほど検索したあとに色を付ける感じですか。
          調べてみたのですが、Ctrl+Fで検索した後に色を付ける方法はなさそうでした。。。

          下記のような形で自作でダイアログを表示して検索しているような動きにすることはできました。
          範囲を選択してマクロを実行すると、選択している範囲を検索します。
          マクロをCtrl + 任意のキーで呼び出せるようにもできるので、Ctrl+Fのかわりにこちらを使うようにはできます。

          Public Sub setColor()
    Dim target As Range
    Set target = Selection

    Dim keyword As String
    keyword = InputBox("検索キーワードを入力してください", keyword)
    
    If keyword = "" Then
        Exit Sub
    End If

    Dim result As Object
    Set result = target.Find(keyword, LookAt:=xlPart)
    Dim first As Object
    Set first = result

    If result Is Nothing Then
        MsgBox "見つかりませんでした。"
        Exit Sub
    End If

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")

    With regexp
        .Pattern = keyword
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For Each c In result.Cells
            Set regResult = .Execute(c)
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                Dim targetCell As Object
                Set targetCell = c
                targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = vbRed
            Next j
            c.Select
        Next
    End With
    
    Do While Not result Is Nothing
        Dim rc As Integer
        rc = MsgBox("次のセルを検索しますか？", vbYesNo + vbQuestion, "確認")
        If rc = vbNo Then
            Exit Sub
        End If
    
    
        Set result = target.FindNext(result)
        If result.Address = first.Address Then
            Exit Do
        End If
        With regexp
            .Pattern = keyword
            .IgnoreCase = True
            .Global = True
            '1行目から使用最終行を対象にする
            For Each c In result.Cells
                Set regResult = .Execute(c)
                For j = 0 To regResult.Count - 1
                    '指定された単語があれば赤色にする
                    Set targetCell = c
                    targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = vbRed
                Next j
                c.Select
            Next
        End With
    Loop
    
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
          返信する

          • 上記のVBAでCtrl+Fよりかなり検索しやすくなりました！何度も質問してすいません。上記の場合だと、毎回範囲を選択しているのですが、VBA上で常に同じ範囲を固定選択することは可能でしょうか？4行目に当たる部分に「Const TARGET_RANGE = “C●:C●”」を追記しても機能しなかったのですが、挿入する位置が悪いのでしょうか？五月雨になってしまいすみません。

          • すみませんー。コメント見逃していて遅くなりました。。。
            同じ範囲を固定選択するなら以下のような感じになると思います。
            3行目の「Set target = ActiveSheet.Range(“C4:C15”)」の部分で指定しているので、C4:C15を変更すれば範囲が変わります。

            Public Sub setColor()
    Dim target As Range
    Set target = ActiveSheet.Range("C4:C15")

    Dim keyword As String
    keyword = InputBox("検索キーワードを入力してください", keyword)
    
    If keyword = "" Then
        Exit Sub
    End If

    Dim result As Object
    Set result = target.Find(keyword, LookAt:=xlPart, After:=target.Item(target.Count))
    Dim first As Object
    Set first = result

    If result Is Nothing Then
        MsgBox "見つかりませんでした。"
        Exit Sub
    End If

    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")

    With regexp
        .Pattern = keyword
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For Each c In result.Cells
            Set regResult = .Execute(c)
            For j = 0 To regResult.Count - 1
                '指定された単語があれば赤色にする
                Dim targetCell As Object
                Set targetCell = c
                targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = vbRed
            Next j
            c.Select
        Next
    End With
    
    Do While Not result Is Nothing
        Dim rc As Integer
        rc = MsgBox("次のセルを検索しますか？", vbYesNo + vbQuestion, "確認")
        If rc = vbNo Then
            Exit Sub
        End If
    
    
        Set result = target.FindNext(result)
        If result.Address = first.Address Then
            Exit Do
        End If
        With regexp
            .Pattern = keyword
            .IgnoreCase = True
            .Global = True
            '1行目から使用最終行を対象にする
            For Each c In result.Cells
                Set regResult = .Execute(c)
                For j = 0 To regResult.Count - 1
                    '指定された単語があれば赤色にする
                    Set targetCell = c
                    targetCell.Characters(Start:=regResult(j).FirstIndex + 1, Length:=regResult(j).Length).Font.Color = vbRed
                Next j
                c.Select
            Next
        End With
    Loop
    
    Set regResult = Nothing
    Set regexp = Nothing
End Sub

  • 初めまして、コメント失礼します。
    「検索キーワード３個、検索列を行にする、文字色の変更」は皆さまのご質問を合わせて修正できました。もう一つご教授いただきたいのですが、私の場合ですと、検索セル行の文字がドロップダウンリストにより選択するようにしています。リストにより選択し直すと、対象文字の色が変更されません。セルの文字列を変更しても色が変わるようにできないでしょうか。ご教授いただけたら幸いです。

    返信する

    • 最近あまりブログ見てなかったので遅くなりました…
      ドロップダウンリストが変更されたときに、任意のVBA処理を実行することができるので、その時に作成されたプログラムを実行すれば自動で変わってくれる動きが実現できると思います。

      例えばドロップダウンがSheet1のA1にある場合は、下記画像のようにSheet1のコードに以下のように記載します。
      「’ここに呼び出したい処理を書く」のところで文字の色を変更する処理をcall で呼び出せば行けると思います。(処理名がsetColorの場合は、call setColorで呼び出す。）

      Private Sub Worksheet_Change(ByVal Target As Range)
    'ドロップダウンリストがあるセルのアドレス
    Const DROP_ADDRESS As String = "A1"
    
    If Target.Address <> DROP_ADDRESS Then
        'ここに呼び出したい処理を書く
        
    End If
End Sub

      返信する

      • 度々申し訳ございません。
        当方、空白（表示なし）も必要でして、検索文字の色を白色にして、印刷されないようにしています。ドロップダウンリストの一つとして「空白」を設け、キーワードにも「空白」としいます。その空白を選択すると、実行通り白色に変化します。しかし、またそのセルで別の文字列を選択し直すと、セルのすべての文字列が白色になってしまいます。（空白以外の文字列の選択後は、正しく表示されます）続いてご教授願えればと思います。

        返信する

        • 実現したいことと違っていたらすみませんが、空白の選択肢の時だけ白色にする処理に入りたいということですよね。
          下記のように書くと空白の場合と空白以外の場合で条件分岐ができます。（Targetに選んだ選択肢が設定されているのでそれで分岐させる。）
          それで空白の場合だけ白色にする処理をcallするようにすれば実現できないでしょうか。

          Private Sub Worksheet_Change(ByVal Target As Range)
    'ドロップダウンリストがあるセルのアドレス
    Const DROP_ADDRESS As String = "A1"
    
    If Target.Address <> DROP_ADDRESS Then
        If Trim(Target) = "" Then
            '空白の場合だけこの分岐に入るので、文字を白色にする処理をここに書く
    
        Else
            '空白以外の場合はこの分岐に入る。文字色を黒色にする処理をここに書く
            
        End If
    End If
End Sub
          返信する

          • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
            ‘ドロップダウンリストがあるセルのアドレス
            Const DROP_ADDRESS As String = “D34:AH34”

            If Target.Address DROP_ADDRESS Then
            ‘ここに呼び出したい処理を書く
            ‘検索するキーワード
            Const KEYWORD = “上|中|下|空白”
            ‘色を塗るセルが格納されている行
            Const ROW_TARGET = 34

            Dim regexp As Object
            Dim i As Long
            Dim j As Long
            Dim regResult As Object
            Set regexp = CreateObject(“VBScript.RegExp”)

            With regexp
            .Pattern = KEYWORD
            .IgnoreCase = True
            .Global = True
            ‘1列目から使用最終列を対象にする
            For i = 1 To ActiveSheet.Cells(ROW_TARGET, Columns.Count).End(xlToLeft).Column
            Set regResult = .Execute(ActiveSheet.Cells(ROW_TARGET, i))
            For j = 0 To regResult.Count – 1
            ‘指定された単語があれば白色にする
            ActiveSheet.Cells(ROW_TARGET, i).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font.Color = RGB(255, 255, 255)
            Next j
            Next i
            End With
            Set regResult = Nothing
            Set regexp = Nothing

            End If
            End Sub

          • 表現至らずすいません。
            例えば「Const KEYWORD = “上|中|下|空白”」～//~
            　　　「.Font.Color = RGB(255, 255, 255)」の文で、ドロップダウンリストより、
            「〇〇上」を選択（正しく「上」のみ白色）その後、同セルで「○○○中」を選択は正しく「中」のみ白色表示されますが、ドロップダウンリストより「空白」を選択（「空白」が白色」）でいいのですが、その次に同セルで「○○○中」を選択すると、「○○○中」すべてが白色に処理されます。正しくキーワードのみ処理するにはどのようにすればいいのでしょうか。長文すみません。

      • ヒロユキ様　ご返信ありがとうございます。
        大変勉強になりました。処理が実行できました。早速使いたいと思います♪

        返信する

        • なるほどですね。
          今、キーワードは常に「上|中|下|空白」にしているのですがドロップダウンで指定した値を使う必要があると思うので、修正してみました。
          あと白色にした文字をもとに戻す処理も必要なので、白色に塗る前にクロにする処理を入れています。
          また、すみませんが前に記載したWorksheet_SelectionChangeだと動いてくれないこともあったのでWorksheet_Changeにしました。

          Private Sub Worksheet_Change(ByVal Target As Range)
'ドロップダウンリストがあるセルのアドレス
    Const DROP_ADDRESS As String = "D34:AH34"
    
    If Not Application.Intersect(Range(Target.Address), Range(DROP_ADDRESS)) Is Nothing Then
    
        'ここに呼び出したい処理を書く
        '検索するキーワード
        Dim keyword As String
        keyword = createKeyword(Target.Value)
        '色を塗るセルが格納されている行
        Const ROW_TARGET = 34
        
        Dim regexp As Object
        Dim i As Long
        Dim j As Long
        Dim regResult As Object
        Set regexp = CreateObject("VBScript.RegExp")
        
        ' 一旦黒色に戻す
        ActiveSheet.Rows(ROW_TARGET).Font.Color = RGB(0, 0, 0)
        
        With regexp
            .Pattern = keyword
            .IgnoreCase = True
            .Global = True
            '1列目から使用最終列を対象にする
            For i = 1 To ActiveSheet.Cells(ROW_TARGET, Columns.Count).End(xlToLeft).Column
                Set regResult = .Execute(ActiveSheet.Cells(ROW_TARGET, i))
                For j = 0 To regResult.Count - 1
                    '指定された単語があれば白色にする
                    ActiveSheet.Cells(ROW_TARGET, i).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(keyword)).Font.Color = RGB(255, 255, 255)
                Next j
            Next i
        End With
        Set regResult = Nothing
        Set regexp = Nothing

    End If
End Sub

Private Function createKeyword(dropdownVal As String) As String
    createKeyword = "上|中|下|空白"

    Dim result As Integer
    
    ' 文字列内に上が含まれているか？
    result = InStr(dropdownVal, "上")
    
    ' 含まれていたら上をキーワードに使う
    If result > 0 Then
        createKeyword = "上"
    End If
    
    ' 文字列内に中が含まれているか？
    result = InStr(dropdownVal, "中")
    
    ' 含まれていたら中をキーワードに使う
    If result > 0 Then
        createKeyword = "中"
    End If
    
    ' 文字列内に下が含まれているか？
    result = InStr(dropdownVal, "下")
    
    ' 含まれていたら下をキーワードに使う
    If result > 0 Then
        createKeyword = "下"
    End If
    
    ' 文字列内に下が含まれているか？
    result = InStr(dropdownVal, "空白")
    
    ' 含まれていたら空白をキーワードに使う
    If result > 0 Then
        createKeyword = "空白"
    End If
    
End Function
          返信する

          • 何度も何度もありがとうございました。
            思っていたものが出来上がりました。本当にありがとうございました。
            感謝です╰(*°▽°*)╯

  • 初めまして。
    皆様と同じく、VBA初心者かつやりたいことを実装してくださっていたので
    参考にさせていただいています。
    大変ありがたいです。
    一点、自分でも調査していたのですがわからず何か解決策があればと思い、
    コメントさせていただきました。
    【やりたいこと】
    ・キーワード（英単語（★））で検索
    ・ヒットすれば赤文字かつ太文字

    ★に関しまして、
    英単語を例えば”he”とした場合、”he”のみを強調したいのですが、
    Theの”he”も強調表示されてしまいます。
    “Tｈｅ（わかりにくいですが、全角半角を使うとこのようなイメージです）”

    この辺り、解決策などもしございましたらご教示いただけないでしょうか。

    検索キーワードを大文字固定にすればいける？と考えて、
    HE
    にしてみたのですが、事象は変わらずでして。。

    返信する

    • 英単語というのをプログラムにどう認識させるかが難しいのですが、以下のようなパターンの場合に赤太字にするという形なら、Theが塗られてしまうのは防げると思います。

      ■赤字にするパターン
      ・キーワードの先頭が大文字で、キーワードの後がスペース（行頭の場合）
      ・キーワードがスペースで囲まれている（文中の場合）
      ・キーワードの前がスペースで、あとがドット(文末の場合)

      もしかしたら考慮漏れがあるかもしれないですが。。。
      VBAで書くと以下になるかと思います。

      Public Sub setColor()
    '検索するキーワード
    Const KEYWORD = "he"
    '色を塗るセルが格納されている列
    Const COL_TARGET = 1
    
    '///////////////////////////////
    'スペース + キーワード + スペースを赤く塗る
    '///////////////////////////////
    Dim regStr As String
    regStr = "[\s]+" & KEYWORD & "[\s]+"

    
    Dim regexp As Object
    Dim i As Long
    Dim j As Long
    Dim regResult As Object
    Set regexp = CreateObject("VBScript.RegExp")
    
    With regexp
        .Pattern = regStr
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                With ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 2, Length:=Len(KEYWORD)).Font
                    '指定された単語があれば赤色にする
                    .Color = vbRed
                    '指定された単語があれば太文字にする
                    .Bold = True
                End With
               
            Next j
        Next i
    End With
    
    
    '///////////////////////////////
    '先頭大文字のキーワード + スペースを赤く塗る
    '///////////////////////////////
    regStr = UCase(Left(KEYWORD, 1)) & Mid(KEYWORD, 2) & "[\s]+"
    With regexp
        .Pattern = regStr
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                With ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 1, Length:=Len(KEYWORD)).Font
                    '指定された単語があれば赤色にする
                    .Color = vbRed
                    '指定された単語があれば太文字にする
                    .Bold = True
                End With
               
            Next j
        Next i
    End With
    
    '///////////////////////////////
    'スペース + キーワード + ドットを赤く塗る
    '///////////////////////////////
    regStr = "[\s]+" & KEYWORD & "."
    With regexp
        .Pattern = regStr
        .IgnoreCase = True
        .Global = True
        '1行目から使用最終行を対象にする
        For i = 1 To ActiveSheet.Cells(Rows.Count, COL_TARGET).End(xlUp).Row
            Set regResult = .Execute(ActiveSheet.Cells(i, COL_TARGET))
            For j = 0 To regResult.Count - 1
                With ActiveSheet.Cells(i, COL_TARGET).Characters(Start:=regResult(j).FirstIndex + 2, Length:=Len(KEYWORD)).Font
                    '指定された単語があれば赤色にする
                    .Color = vbRed
                    '指定された単語があれば太文字にする
                    .Bold = True
                End With
               
            Next j
        Next i
    End With
    
    Set regResult = Nothing
    Set regexp = Nothing
End Sub
      返信する

    • ヒロユキ へ返信する コメントをキャンセル

    メールアドレスが公開されることはありません。

    日本語が含まれない投稿は無視されますのでご注意ください。（スパム対策）

    ABOUTこの記事をかいた人

    VBAによるEXCELアプリケーション開発の業務経験を生かし、日々の業務でもVBAを使用して生産性の向上を図っています。

    NEW POST最新の記事

    RECOMMENDこちらの記事も人気です。