【エクセルマクロ】セルの文字列を参照して、となりのセルの文字に色をつけたい。



アクティブシートで、B列にある文字を読み取ってその左となりのA列の文字に色をつけたいです。


・B列には数文字程度、文字がはいっています。

その中に含まれる1文字を読み取って、それに対応する色を同じ行のA列の文字につけたいです。

基本4種類対応していただきたいのですが、
下記の対応表に付け加えても対応できるようにしていただけると助かります。


色の値はRGB値にしておいてくださるとあとで調整できますので、助かります。


【対応表】

A列(RGB値の色をつけます。)・B列(セル内を検索する文字)
※A列には実際には文字列が入っています

000000・定
0000C0・佐
006000・ヤ
E00000・ゆ



【注意点】
・B列に1文字でも含まれていたら処理します

・B列内に対応する文字がないときは何もしません

・万が一エラーがでたら無視して下の行を処理していきます。

・1行目(A,B列とも)は見出しで、下に向かって動いていって、A列が空白になったときにマクロが止まります。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2012/11/16 18:10:12
  • 終了:2012/11/16 22:55:32

ベストアンサー

id:ku__ra__ge No.2

ku__ra__ge回答回数118ベストアンサー獲得回数402012/11/16 21:19:36

ポイント100pt

以下のマクロを利用してみてください。
色や検索する文字を調整したい場合、「Private Function getColorTable()」以降の行を編集します。

Public Sub setSheetColor()
    Set colorTable = getColorTable()
    
    Set r = Range("B2")
    Do While r.Offset(0, -1).Text <> ""
    
        Call setCellColor(r, colorTable)
    
        Set r = r.Offset(1, 0)
    Loop

    MsgBox "end."
End Sub

Private Sub setCellColor(r, colorTable)
    For Each key In colorTable.Keys
        If InStr(r.Text, key) > 0 Then
            r.Offset(0, -1).Font.Color = colorTable(key)
        End If
    Next
End Sub

Private Function getColorTable()
    Set getColorTable = CreateObject("Scripting.Dictionary")
    
    Call getColorTable.Add("定", CLng("&H000000"))
    Call getColorTable.Add("佐", CLng("&H0000C0"))
    Call getColorTable.Add("ヤ", CLng("&H006000"))
    Call getColorTable.Add("ゆ", CLng("&HE00000"))
End Function
id:naranara19

項目を足してみましたが、完璧に動きました!要望通りとなっており、とても感謝しております。本当にありがとうございます。

2012/11/16 22:54:44

その他の回答(1件)

id:gizmo5 No.1

gizmo5回答回数484ベストアンサー獲得回数1382012/11/16 18:52:05

ポイント50pt

マクロを作らなくても、条件付き書式で希望されていることが可能です。

  1. A列を選択
  2. 条件付き書式→新しいルール
  3. 数式を使用して、書式設定するセルを選択
  4. 数式に、以下のように入力
    =find("定",b1)
  5. 書式ボタンをクリック
  6. フォントタブの「色」で、「その他の色」をクリック
  7. 「ユーザ設定」タブを選択
  8. カラーモデルでRGBを選んで、赤緑青の数値(10進数)を指定

上記を四回繰り返して、数式の検索する文字と、フォントの色を指定していきます。
条件が四つできるので、優先させたい色を最初の方にしてください。

id:naranara19

すでにある色がついていて、その色が他のマクロで必要情報でして、そのようにできないのです。しかし、価値ある回答で感謝します!ご指摘ありがとうございました。

2012/11/16 19:56:50
id:ku__ra__ge No.2

ku__ra__ge回答回数118ベストアンサー獲得回数402012/11/16 21:19:36ここでベストアンサー

ポイント100pt

以下のマクロを利用してみてください。
色や検索する文字を調整したい場合、「Private Function getColorTable()」以降の行を編集します。

Public Sub setSheetColor()
    Set colorTable = getColorTable()
    
    Set r = Range("B2")
    Do While r.Offset(0, -1).Text <> ""
    
        Call setCellColor(r, colorTable)
    
        Set r = r.Offset(1, 0)
    Loop

    MsgBox "end."
End Sub

Private Sub setCellColor(r, colorTable)
    For Each key In colorTable.Keys
        If InStr(r.Text, key) > 0 Then
            r.Offset(0, -1).Font.Color = colorTable(key)
        End If
    Next
End Sub

Private Function getColorTable()
    Set getColorTable = CreateObject("Scripting.Dictionary")
    
    Call getColorTable.Add("定", CLng("&H000000"))
    Call getColorTable.Add("佐", CLng("&H0000C0"))
    Call getColorTable.Add("ヤ", CLng("&H006000"))
    Call getColorTable.Add("ゆ", CLng("&HE00000"))
End Function
id:naranara19

項目を足してみましたが、完璧に動きました!要望通りとなっており、とても感謝しております。本当にありがとうございます。

2012/11/16 22:54:44
id:naranara19

お二人とも感謝します。誠にありがとうございました。またお付き合いくださいませ!

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません