VBAで背景色

質問

以前にも同じような質問をしたのですが、応用できなかったので改めて質問させていただきます。申し訳ありません。

VBAを使って、入力された値によってセルの背景色を変更したいです。

C列からAF列までのセルに
「1」から始まる値が入力されたら背景を黄色　例:「1テスト」
「2」から始まる値が入力されたら背景を緑色　例:「2VBA」
「3」から始まる値が入力されたら背景を水色　例:「3教えて」
「4」から始まる値が入力されたら背景を赤　　例:「4終了」
にするVBAが欲しいです。

例えば、C1に入力した「1テスト」という値を、D1～AF1にコピーすれば
C1～AF1の背景が黄色になるようにしたいわけです。
かつ、B列にはその行で背景が黄色のセルの数を返せれば最高です。
どの部分が「C列からAF列」を指すのかをご説明いただけると大変ありがたいです。
よろしくお願いします。

回答No.8

merlionXX · ベストアンサー

> 背景色が反映されるまで5秒ほどかかるのがちょっときになりますが。。。

変ですね、わたしはWin2000で同様に保護をかけてやってみましたが、瞬時に色が変わりました。

お礼

>変ですね、わたしはWin2000で同様に保護をかけてやってみましたが、瞬時に色が変わりました。

おそらく、Macだからだと思います。
明日、会社のWinで確認してみます。

何度も何度もご丁寧にお答えいただきありがとうございました。

回答No.7

merlionXX

もし、そのような機能が無かったら、奥の手ですが、セルの色を変える一瞬だけ保護を解除しちゃうって手もありますね。
No5のコードの下のほうですが、以下のように変えてみてください。（パスワードはmerlionとしてますが実際のものに変えてくださいね）

ActiveSheet.Unprotect Password:="merlion" 'シート保護解除
r.Interior.ColorIndex = c 'セル背景色を色番号の色に変える
ActiveSheet.Protect Password:="merlion" 'シート保護

補足

上記コードで一時的に保護を解除できました。
背景色が反映されるまで5秒ほどかかるのがちょっときになりますが。。。

エクセルの2003以降なら保護の際に「書式変更は許可」のようなことができるようです。Mac版エクセル2004ではそれがありませんでした。
もし、Win版2003でその保護をしたファイルを、Win版2000やMac版2004で開いたらどうなるんでしょう？

なかなかうまくいかないものですね。

回答No.6

merlionXX

> 保護は使えないのでしょうか？またこれはMacでしか確認していません。

シート保護すると、ロックを外したセルも「書式の変更」はできなくなるので、色を変えるマクロはエラーになります。

わたしは２００４を使ったことがないのですが、わたしの２０００より上位のバージョンには、保護をかける際に、「書式の変更」はOKにするような機能は無かったでしたっけ？

補足

winでもmacでも保護の対象は「データ」「オブジェクト」「シナリオ」だけのようです。　書式の変更はデータに入るのでしょうか？

回答No.5

merlionXX

Macでも上手くいったのでしょうか？

> merlionXXさんは前回の質問の時に教えていただいたサイトでＶＢＡを覚えられたんですか？

あそこもそうですし、他にも探すと役立つサイトはたくさんありますよ。
ここでもいろいろ教えてもらいましたし。

あと、どうでもいいところですが、コードを少し直してみました。

Private Sub Worksheet_Change(ByVal Target As Range) 'チェンジイベントで作動

If Target.Column < 3 Or Target.Column > 32 Then Exit Sub '3～32列に入力時以外はマクロ終了
If Selection.Rows.Count > 1 Then 'もし複数行を選択した場合
MsgBox "複数行を操作しないで下さい。（複数列はOKです）", vbCritical, "Σ（￣ロ￣lll) " '警告
With Application
.EnableEvents = False 'イベント発生一時停止
.Undo 'やり直し
.EnableEvents = True 'イベント発生再開
End With
Exit Sub 'マクロ終了
End If '「場合」終わり
Dim l As Long, c As Integer, v As Variant, r As Range, x As Variant
l = Target.Row '入力行を取得
x = 0 'カウントを０にする
For Each r In Range(Cells(l, "C"), Cells(l, "AF")) '入力行のC～AF各セルについて
v = Val(StrConv(Left(r.Value, 1), vbNarrow)) '先頭の1文字を半角数値化
Select Case v '先頭の1文字で分岐
Case "" '空白の場合、何もしない
Case 1 '先頭の1文字が1の場合
c = 6: x = x + 1 '色番号6、カウントする
Case 2 '2の場合
c = 4 '色番号4
Case 3 '3の場合
c = 34 '色番号34
Case 4 '4の場合
c = 3 '色番号3
Case Else 'その他の場合
c = 0 '色番号0
End Select '分岐終了
r.Interior.ColorIndex = c 'セル背景色を色番号の色に変える
Next '繰り返し
x = IIf(x > 0, x, "") 'カウントが0なら無し
Cells(l, "B") = x '入力行のBセルにカウントした数を代入

End Sub

補足

No.4のコードでMacでも正常に動作しました。
No.5も同様です。
ありがとうございます。

現在No.5のコードを使用していますが、B～AF列以外を保護したら
「実行時エラー1004」と出ました。
保護は使えないのでしょうか？またこれはMacでしか確認していません。

回答No.4

merlionXX

おはようございます、ao_さん。
Macだったのですね。わたしは、OSがWindows2000,Excel2000とOSがWindowsXP,Excel2003でNo2のコードをそのままコピペして試してみましたが問題なく動きました。
再度、修正してみますが、これでもダメならお手上げです。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 Or Target.Column > 32 Then Exit Sub '3～32列を対象
If Selection.Rows.Count > 1 Then
MsgBox "縦にドラッグしないで下さい。（横はOK）"
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Exit Sub
End If

Dim l As Long, c As Integer, v As String, r As Range, x As Variant

l = Target.Row '入力行取得
x = 0
For Each r In Range("C" & l & ":AF" & l) '入力行各セルについて
v = Val(StrConv(Left(r.Value, 1), vbNarrow)) '先頭の1文字を半角数値化
Select Case v '先頭の1文字で判定
Case 1 '先頭の1文字が1の場合
c = 6: x = x + 1 '色番号6、カウントする
Case 2 '先頭の1文字が2の場合
c = 4 '色番号4・・・以下略
Case 3
c = 34
Case 4
c = 3
Case Else 'その他の場合
c = 0
End Select
r.Interior.ColorIndex = c 'セル背景色を色番号のものに変える
Next '繰り返し
x = IIf(x > 0, x, "") 'カウントが0なら無し
Cells(l, "B") = x '入力行のBセルにカウントした数を代入
End Sub

お礼

ありがとうございます。
現在職場にいるため、Macで確認できないのですが、ＷＩＮで試したところ、正常に機能しました。
コメントも書いていただいたので細かな変更もできそうです
本当にありがとうございます。

merlionXXさんは前回の質問の時に教えていただいたサイトでＶＢＡを覚えられたんですか？

回答No.3

moooon

変ですね。私も興味があったのでNo2のコードをそのままコピーしてみましたが正しく作動しましたが。

補足

私の環境がMacで、OfficeMac2004を利用していることに何か関係があるのでしょうか？　何度やってもエラーになってしまいます。

回答No.2

merlionXX

> 標準モジュールを作成し、コピーしてみましたが、反応がありません。

シートのモジュールにコピペしてくださいと書いたと思います。
ao_さんの以前の質問、QNo.2597539でも同様だと思いますが、セルの入力値の変化というチェンジイベントを捉えて作動するのがPrivate Sub Worksheet_Changeのコードです。標準モジュールではだめです。

ついでですから、コードもちょと修正してみました。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 Or Target.Column > 32 Then Exit Sub '3～32列を対象
If Selection.Rows.Count > 1 Then
MsgBox "縦にドラッグしないで下さい。（横はOK）"
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Exit Sub
End If
l = Target.Row '入力行取得
x = 0
For Each r In Range("C" & l & ":AF" & l) '入力行各セルについて
Select Case Left(r, 1) '先頭の1文字で判定
Case 1 '先頭の1文字が1の場合
c = 6: x = x + 1 '色番号6、カウントする
Case 2 '先頭の1文字が2の場合
c = 4 '色番号4・・・以下略
Case 3
c = 34
Case 4
c = 3
Case Else 'その他の場合
c = 0
End Select
r.Interior.ColorIndex = c 'セル背景色を色番号のものに変える
Next '繰り返し
x = IIf(x > 0, x, "") 'カウントが0なら無し
Cells(l, "B") = x '入力行のBセルにカウントした数を代入
End Sub

お試し下さい。

補足

ありがとうございます。
初心者なもので大変申し訳ありません。

シートのモジュールにコピペしました。
C1に「1テスト」と入力したところ、
「実行時エラー13　型が一致しません。」
と出ました。デバックをクリックすると
「Case 1 '先頭の1文字が1の場合」の部分が黄色に反転表示されました。
また、C2に入力すると反応がありませんでした。
どこを修正すればいいのでしょうか。

回答No.1

merlionXX

ao_さん、こんにちは。
対象シートのモジュールに以下をコピペしてみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 Or Target.Column > 32 Then Exit Sub '3～32列を対象
l = Target.Row '入力行取得
x = 0
For Each r In Range("C" & l & ":AF" & l) '入力行各セルについて
Select Case Left(r, 1) '先頭の1文字で判定
Case 1 '先頭の1文字が1の場合
c = 6: x = x + 1 '色番号6、カウントする
Case 2 '先頭の1文字が2の場合
c = 4 '色番号4・・・以下略
Case 3
c = 34
Case 4
c = 3
Case Else 'その他の場合
c = 0
End Select
r.Interior.ColorIndex = c 'セル背景色を色番号のものに変える
Next '繰り返し
x = IIf(x > 0, x, "") 'カウントが0なら無し
Cells(l, "B") = x '入力行のBセルにカウントした数を代入
End Sub

補足

毎度ありがとうございます。

＞対象シートのモジュールに以下をコピペしてみてください。

標準モジュールを作成し、コピーしてみましたが、反応がありません。
シートタブを右クリックして表示されるコードの表示にペーストするのでしょうか？