エクセルのセルの背景色をレベルごと（12パターン）に色分けしたいのですが。

質問

エクセルでラベルシールを作りたいと思っています。
Sheet1のA1に本のタイトルを入力すると、Sheet2のA1に同じくタイトルが表示され、Sheet1のB2に「Level 1」と入力すると、Sheet2のB2のセルに「L1」と表示され、かつB2のセルの背景色が黄色になる、という風に設定をしたいのです。Sheet1をリストとして使用し、Sheet2を実際のラベルとして使用します。レベルは0から11まであり、背景色を12パターン用意しないといけないので、3つまでしか設定できない「条件付き書式」の設定では対応できず、こちらにお尋ねしました。
だれでも使えるファイルを作成するため、マクロを登録してボタンクリックでラベル作成を行ないたいです。
VBEの画面に貼り付けることができるコードを教えていただけないでしょうか。
初めての投稿のため、説明が不十分かと思います。足りない部分は追って補足させて頂きますので、詳しい方、どうぞお知恵をお貸し下さい。

回答No.4

ka_na_de · ベストアンサー

＃２です。

改良してみました。お試しください。

'==============Sheet1のシートモジュールに記述===================
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myWs As Worksheet
　　Dim myLevel, myColor

　　If Target.Count <> 1 Then Exit Sub

　　Set myWs = Sheets("Sheet2")

　　'色のIndex番号です。適当な数字を入れています。変更して下さい。
　　myColor = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)

　　With myWs.Range(Target.Address)
　　　　Select Case Target.Column
　　　　　　Case 1, 3, 5 ' A,C,E列
　　　　　　 .Value = Target.Value
　　　　　　Case 2, 4, 6 ' B,D,F列
　　　　　　　　myLevel = Trim(Replace(Target.Value, "Level", ""))
　　　　　　　　If myLevel = "" Then
　　　　　　　　　　.Value = ""
　　　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　　　ElseIf myLevel >= LBound(myColor) And _
　　　　　　　　　　　　 myLevel <= UBound(myColor) Then
　　　　　　　　　　.Value = "L" & myLevel
　　　　　　　　　　.Interior.ColorIndex = myColor(myLevel)
　　　　　　　　Else
　　　　　　　　　　.Value = "Error"
　　　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　　　End If
　　　　End Select
　　End With

　　Set myWs = Nothing
End Sub

お礼

早速ありがとうございます。
やってみました。理想どおり、完璧なものにしていただいて、心より感謝です。ka_na_de様、本当にありがとうございました。

回答No.3

ka_na_de

＃２です。

色の数を12パターン以上に増やしても大丈夫なように変更しました。
ご参考までに。

'==============Sheet1のシートモジュールに記述===================
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myWs As Worksheet
　　Dim myLevel, myColor

　　If Target.Count <> 1 Then Exit Sub

　　Set myWs = Sheets("Sheet2")

　　'色のIndex番号です。適当な数字を入れています。変更して下さい。
　　myColor = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)

　　With myWs.Range(Target.Address)
　　　　If Target.Column = 1 Then ' A列
　　　　　　.Value = Target.Value
　　　　ElseIf Target.Column = 2 Then ' B列
　　　　　　myLevel = Trim(Replace(Target.Value, "Level", ""))
　　　　　　If myLevel = "" Then
　　　　　　　　.Value = ""
　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　ElseIf myLevel >= LBound(myColor) And _
　　　　　　　　　　myLevel <= UBound(myColor) Then
　　　　　　　　.Value = "L" & myLevel
　　　　　　　　.Interior.ColorIndex = myColor(myLevel)
　　　　　　Else
　　　　　　　　.Value = "Error"
　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　End If
　　　　End If
　　End With

　　Set myWs = Nothing
End Sub

補足

ご回答ありがとうございます。ご指摘通り、入力直後にセルの色を変えたかったので、助かりました。ここで申し訳ないのですが、私の説明不足があり、もしまたお助けいただけましたらお願いします。
A列B列で行ったことと同じことを、C列D列、E列F列、でも行いたいのですか、可能でしょうか？ラベルシートがA4サイズで、F列まで使うということを記載漏れしていました。
理想のラベル作成がうまくいきそうで、是非お力をお貸し頂ければ幸いです。
よろしくお願いいたします。

回答No.2

ka_na_de

一例です。

質問の前半では、入力後ただちに背景色を変化させたいようですが、
後半では、ボタンクリックで実行となっています。

最終的にどうしたいのか分かりませんが、とりあえず
入力後ただちに実行する場合の例です。

'==============Sheet1のシートモジュールに記述===================
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myWs As Worksheet
　　Dim myLevel, myColor

　　If Target.Count <> 1 Then Exit Sub

　　Set myWs = Sheets("Sheet2")
　　myColor = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)

　　With myWs.Range(Target.Address)
　　　　If Target.Column = 1 Then
　　　　　　.Value = Target.Value
　　　　ElseIf Target.Column = 2 Then
　　　　　　myLevel = Trim(Replace(Target.Value, "Level", ""))
　　　　　　If myLevel = "" Then
　　　　　　　　.Value = ""
　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　ElseIf myLevel >= 0 And myLevel <= 11 Then
　　　　　　　　.Value = "L" & myLevel
　　　　　　　　.Interior.ColorIndex = myColor(myLevel)
　　　　　　Else
　　　　　　　　.Value = "Error"
　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　End If
　　　　End If
　　End With

　　Set myWs = Nothing
End Sub

回答No.1

hallo-2007

ヒントだけです。
>Sheet1のA1に本のタイトルを入力すると、
シートのモジュールに、Changeのイベントで実行させる。
Sheet1のシート名タブを右クリック、コードの表示
GeneralをWorksheetに変える、右側を　Changeに変更すれば
Private Sub Worksheet_Change(ByVal Target As Range)

End Sub
が作成されます。

>Sheet2のA1に同じくタイトルが表示され
Sheets("Sheet2").Range(Target.Address).Value = Target.Value
>B2のセルの背景色が黄色になる
仮に　B2に数値を入れるものとして、セルの色を変える場合
Sheets("Sheet2").Range(Target.Address).Interior.ColorIndex = Target.Value

参考です。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 Then
Sheets("Sheet2").Range(Target.Address).Value = Target.Value
End If
If Target.Column = 2 Then
Sheets("Sheet2").Range(Target.Address).Interior.ColorIndex = Target.Value
End If
End Sub

お礼

早速のご回答誠にありがとうございます。
トライしてみます。また分からないことがありましたらお尋ねさせてください。取り急ぎお礼まで。