マクロでシートタブ色の変更

質問

例えば、A1に数字が入ればシートタブが青色に、A1とA2に数字が入ればシートタブが黄色に、
A1とA2とA3に数字が入ればシートタブが赤色に、このようにするにはどのように記述したら良いでしょうか、よろしくお願いいたします。

回答No.1

imogasi · ベストアンサー

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Range("A1:A3"), Target) Is Nothing Then
Worksheets("Sheet1").Tab.ColorIndex = -4142
If Range("A1") <> "" And Range("A2") <> "" And Range("A3") <> "" Then
Worksheets("Sheet1").Tab.ColorIndex = 3
ElseIf Range("A1") <> "" And Range("A2") <> "" Then
Worksheets("Sheet1").Tab.ColorIndex = 6
ElseIf Range("A1") <> "" Then
Worksheets("Sheet1").Tab.ColorIndex = 5
End If
End If
End Sub
これで良いのかな。
ーー
結構、初心者には勉強点があるように思う。
（１）シートイベントというものの勉強
（２）マクロの記録でタブの色を変えるコードを勉強する
また色を抹消するコードを勉強する。
（３）３つの場合の場合分け（条件の多いほうから聞く）
（４）A1:A3以外は素通りさせる方が良いかな（ntersectの利用。これはIFでORを使っても出来る）
数字かどうかのチェックを略している（IsNumericで、使って追加してください）
しかしこの質問のアイデアは珍奇で使えるのかな（今まで質問に出たこと無いような）。
Changeイベントを扱う難しさなどがある。上記コードでは多数例テストして無いので、出来るだけテストして見てください。

お礼

ありがとうございました。ThisWorkbookで一部修正で出来るようになりました。
本当に助かりました。

補足

ありがとうございます。この動作を全てのシートで動作させるにはどうすればいいでしょうか。

回答No.3

merlionXX

ANo2です。

> ありがとうございます。この動作を全てのシートで動作させるにはどうすればいいでしょうか。

すべてのシートのシートモジュールに同じコードをはりつけるか、あるいは先ほどのシートのモジュールのコードを消して
シートモジュールではなく、ThisWorkbookモジュールに

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
　　Dim c
　　If Intersect(Target, Range("A1:A3")) Is Nothing Then Exit Sub
　　If Not IsNumeric(Target.Value) Then Exit Sub
　　Select Case True
　　　　Case Application.Count(Range("A1:A3")) = 3
　　　　c = 3
　　　　Case Application.Count(Range("A1:A3")) = 2
　　　　c = IIf(Application.Count(Range("A1:A2")) = 2, 6, xlNone)
　　　　Case Application.Count(Range("A1:A3")) = 1
　　　　c = IIf(Application.Count(Range("A1")) = 1, 5, xlNone)
　　End Select
　　ActiveSheet.Tab.ColorIndex = c
End Sub

を貼ります。（似てますが微妙に違います。）

お礼

ありがとうございました。ベストアンサーに選べず申し訳ありません。
次回もよろしくお願いいたします。

回答No.2

merlionXX

A1に数字
A1、A2に数字
A1、A2、A3に数字　の場合はわかりましたが

たとえば、A1、A3に数字　あるいは、A2だけ数字　という場合がかかれていません。
そういう場合はシートタブに色をつけないのなら手順は下記のとおりです。

1. そのようにしたいシートのタブを右クリックして、[コードの表示]。
2. 出てきた白い所に、以下のコードを貼付けます。

'********これより下**********

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c
If Intersect(Target, Range("A1:A3")) Is Nothing Then Exit Sub
If Not IsNumeric(Target.Value) Then Exit Sub
Select Case True
Case Application.Count(Range("A1:A3")) = 3
c = 3
Case Application.Count(Range("A1:A3")) = 2
c = IIf(Application.Count(Range("A1:A2")) = 2, 6, xlNone)
Case Application.Count(Range("A1:A3")) = 1
c = IIf(Application.Count(Range("A1")) = 1, 5, xlNone)
End Select
Me.Tab.ColorIndex = c
End Sub

'********これより上**********

3.Alt+F11キーでワークシートへもどります。

これでOK
A1からA3に数字を打ち込んで見てください。

お礼

ありがとうございました。ThisWorkbookで一部修正で出来るようになりました。
本当にありがとうございました。

補足

ありがとうございます。この動作を全てのシートで動作させるにはどうすればいいでしょうか。