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

質問

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

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

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

ご教授ください。

回答No.3

keithin

＞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

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

こんにちは！
一例です。

↓の画像のように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