【Excelネタ】指定した文字の色を変更する
この記事でやること
セルの文字を変更するのではなく、セル内の特定の文字色を自動で変更したいと思い、VBAでプログラムを書きましたので紹介します。
文字をハイライトすることで見やすくなります。
仕様とプログラム内容
セルを範囲選択してからプログラムを実行します。
実行すると以下の順番で入力を求められます。
①色を変更するテキストを入力(半角スペース区切りで複数入力可)
②変更後の文字色を指定
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
Sub ChangeTextColor() '色を変更するテキスト Dim ans1 As String ans1 = InputBox("色を変更するテキストを入力してください" & vbCr & "半角スペース区切りで複数入力可能", "テキストの指定", "") If ans1 = "" Then MsgBox "テキストを入力してください" End End If '色の指定 Dim ans2 As String ans2 = InputBox("ColorIndexを入力してください" & vbCr & "例(赤:3、青:5、緑:10)", "色の指定", "3") If ans2 = "" Then MsgBox "ColorIndexを入力してください" End End If Dim MyBoom() As String Dim CelLen As String Dim MyData As String Dim MyDataLen As String Dim Poji As String Dim I As Integer Dim j As Integer Dim Cel As Object MyBoom() = Split(ans1) For Each Cel In Selection CelLen = Len(Cel) 'セル内の文字数 For I = 0 To UBound(MyBoom) MyData = MyBoom(I) '検索対象文字 MyDataLen = Len(MyData) '検索対象文字数 Poji = InStr(1, Cel.Value, MyData) '検索してヒットしたら色変更 If Poji > 0 Then Cel.Characters(Poji, MyDataLen).Font.ColorIndex = ans2 End If For j = 0 To CelLen Poji = InStr((Poji + MyDataLen + j), Cel.Value, MyData) '検索してヒットしたら色変更 If Poji > 0 Then Cel.Characters(Poji, MyDataLen).Font.ColorIndex = ans2 End If Next Next Next MsgBox "完了しました" End Sub |
活用例
マクロとして登録し、実行する場合の例です。
①Excelファイルの作成
任意の場所にマクロ有効ブックとしてファイルを作成します。
②開発タブより「マクロ」を選択
※開発タブの表示方法はこちら
③マクロ名を入力し、作成
マクロ名:ChangeTextColor
④上記プログラムを貼り付け
⑤色を変更する対象のセルを範囲選択し、実行
⑥色を変更するテキストを入力(半角スペース区切りで複数入力可)
⑦変更後の文字色を指定
⑧文字色が変更されます
アドイン(常設メニュー)化
プログラムをアドイン化する方法の記事も書いていますので、良かったら見てみてください!
2023/04/12 追記:ChatGPTに改善させてみた
最後まで読んで頂きありがとうございました^^
この投稿へのトラックバック
トラックバックはありません。
- トラックバック URL
この投稿へのコメント
教えてください。
ひとつのセルに繰り返し同じ文字が出てくる場合に、色が変わらない事があります。
修正方法はあるでしょうか?
併せてで申し訳ないですが、色付きイタリック調太字で目立たせる方法も教えていただけると助かります。
「ひとつのセルに繰り返し同じ文字が出てくる場合に、色が変わらない」については、再現しなかったので確認できませんでした。
「色付きイタリック調太字で目立たせる」については、試しにChatGPTに直させたところ出来てしまいました。。
ブログ書きましたので、良かったら試してみてください。
ChatGPTが優秀過ぎる件(ほとんどVBA書いてくれる)
1点目の質問も、細かい事象をChatGPTに聞いたら修正してくれるかもしれませんね。
お試しいただければと思います。