[[20100821224618]]　『会社別に色をつけたい』（ゆき）　ページの最後に飛ぶ

『会社別に色をつけたい』（ゆき）

 宜しくお願い致します
 D3：D102　に１３の会社名が入るのですが、入力された１３の会社名別に　そのセルに色を付けたいのですが、
 D3：D102に １３の会社名が　下に向けて　入るのですが　山田建設の　セルは赤、
 田中建設は　青　と変わると、後から　見やすいので　　３：１０２まで 
 それぞれの設定した色に変えたいのです。

 D3:D102に入った１３の会社名 で　まずD3:D102　が　それぞれの色で塗りつぶされて、
 そして　同じく隣の　E3:E102のE列も　D列のセルに　塗られた同じ色にしたいのですが　教えて頂けますでしょうか？

 例えば　D３に　山田建設　と入ったら　D3とE3　共に赤にしたいのです。
 E3に　入る言葉は　D3と同じく　山田建設　と書かれる場合もあれば　その他　と書かれる場合もあるのですが　E　に入る言葉は　無視して
 D3に入る言葉で　D3とE3　を共に　赤になるようにしたいのですが 
 すいません　教えて頂けますでしょうか　宜しくお願い致します　m(__)m

 マクロになりますが、
 同一ブックに 色定義 というシートを追加し、A列の先頭から会社名の
 一覧（今回はA1:A13）を列挙します。
 A1:A13のそれぞれのセルの背景色に色を設定します。

 対象のシートに戻って、下記のマクロを実行してどうでしょうか。

 Sub YukiPaint()
    Dim cWS As Worksheet
    Set cWS = Worksheets("色定義")
    Dim cRow As Long
    cRow = cWS.Range("A" & Rows.Count).End(xlUp).Row

    Dim lastRow As Long
    lastRow = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row

    Dim objDic
    Set objDic = CreateObject("Scripting.Dictionary")

    Dim r As Long
    For r = 1 To cRow
        objDic.Add cWS.Cells(r, "A").Value, cWS.Cells(r, "A").Interior.ColorIndex
    Next

    For r = 1 To lastRow
        If objDic.exists(ActiveSheet.Cells(r, "D").Value) Then
            ActiveSheet.Cells(r, "D").Resize(1, 2).Interior.ColorIndex = _
                objDic(ActiveSheet.Cells(r, "D").Value)
        Else
            ActiveSheet.Cells(r, "D").Resize(1, 2).Interior.ColorIndex = xlNone
        End If
    Next
 End Sub
 (Mook)

（ゆき）MOOKさん　ありがとうございました。何とか出来ました！！ありがとうございました。綺麗に色がでました　ありがとうございました。

コメント返信：

[ 一覧(最新更新順) ]

[[20100821224618]] 『会社別に色をつけたい』（ゆき） ページの最後に飛ぶ

[[20100821224618]]　『会社別に色をつけたい』（ゆき）　ページの最後に飛ぶ