Excel 2003 プルダウンでセル色変え

Excel2003で、8種類の条件により列の色変え処理をしたいのです。

A列は、入力規則のドロップダウン リストにより入力します。
A列に入力されたことにより、B列からF列まで別シートからVLOOKUP関数によりデータが入ります。
B列は、1～8の数値データです。

B列の1～8の数値データにより、A列～F列まてのセルを色変えしたいと考えてます。
マクロとしては、どのように記述したら良いでしょか？

ご教授ください。

No.3 回答者： keithin 回答日時： 2013/05/23 15:58

＞A列に入力されたことにより、……

＞B列は、1～8の数値データです

Ａ列の入力を受けて，計算されたＢ列の値を拾って色を塗ります。


手順：
シート名タブを右クリックしてコードの表示を選ぶ
現れたシートに下記をコピー貼り付ける

private sub Worksheet_Change(byval Target as excel.range)
　dim h as range
　dim a as variant
　a = array(3,4,5,6,7,8,19,20)

　on error resume next
　for each h in application.intersect(target, range("A:A"))
　　cells(h.row, "A").resize(1, 6).interior.colorindex = xlnone
　　cells(h.row, "A").resize(1, 6).interior.colorindex = a(cells(h.row, "B").value - 1)
　next
end sub

ファイルメニューから終了してエクセルに戻る
Ａ列に何か記入すると，Ｂ列が１から８まで変わり色が付く。
実際にはＢ列は１から８だけとは限らず，例えば値が入らない値をＡ列に記入する（たとえばＡ列でDelteする，Ｂ列で計算できない値が入ってエラーが出る）と，色が消える。

No.2 回答者： tom04 回答日時： 2013/05/23 14:54

No.1です！

たびたびごめんなさい。

＞B列の1～8の数値データにより・・・
の部分を見逃していました。

前回のコードはA列に1～8が入る前提でのコードですので、前回のコードは無視して
↓のコードに変更してください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim c As Range
If Application.Intersect(Target, Range("A:A")) Is Nothing Or Target.Count <> 1 Then Exit Sub
With Target
.Resize(1.6).Interior.ColorIndex = xlNone
Set c = Worksheets("Sheet2").Range("A:A").Find(what:=.Offset(, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Resize(1, 6).Interior.ColorIndex = c.Offset(, 1).Interior.ColorIndex
End If
End With
End Sub 'この行まで

※　Sheet2は前回同様ですが、Sheet2のA列は作業するSheetのB列に表示されるデータにしておきます。
※　作業SheetのB列データは数式によって表示されるデータというコトですので、B列のチェンジイベントではダメだと思います。。
そこで今回もA列のチェンジイベントにしています。

何度も失礼しました。m（_ _）m

No.1 回答者： tom04 回答日時： 2013/05/23 14:29

こんにちは！

一例です。

↓の画像のようにSheet2のB列の色をA列に入るデータで塗りつぶしておきます。
その下準備ができた上での方法です。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてA列にデータを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim c As Range
If Application.Intersect(Target, Range("A:A")) Is Nothing Or Target.Count <> 1 Then Exit Sub
With Target
.Resize(1, 6).Interior.ColorIndex = xlNone
Set c = Worksheets("Sheet2").Range("A:A").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Resize(1, 6).Interior.ColorIndex = c.Offset(, 1).Interior.ColorIndex
End If
End With
End Sub 'この行まで

こんなんではどうでしょうか？m（_ _）m