エクセルVBAでの複数のオートシェイプの色塗り方法

質問

ネットから下記のコードを見つけたのですが、１つのシートに複数のオートシェイプの色塗りを変更する方法を教えてください。

例えばセル"A1"には数値の1と"A2"には数値2を入力したら、
オートシェイプAにはセル"A1"に対応した色塗り『赤色』を
オートシェイプBにはセル"A2"に対応した色塗り『黄色』といった感じです。
下記のコードをいくつも繋げれば、複数のオートシェイプの色塗りが出来ると思ったのですが、コードを繋げる方法がわかりません。その他に何か良い方法がありましたら教えてください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "A1" Then Exit Sub
With ActiveSheet.Shapes("ABC").Fill.ForeColor
Select Case Target.Value
Case Is = "赤"
.SchemeColor = 2
Case Is = "黄"
.SchemeColor = 5
Case Is = "緑"
.SchemeColor = 3
Case Is = "青"
.SchemeColor = 4
Case Else
.SchemeColor = 1
End Select
End With
End Sub

回答No.5

watabe007 · ベストアンサー

>セル"A1"や"A2"に計算式（関数など）が入っている場合は
数式によりセルの値が変化してもWorksheet_Changeイベントは
動かないのでWorksheet_Calculateイベントを使ってみましょう
Private Sub Worksheet_Calculate()
Dim shp(1 To 2) As Shape
Dim c As Range, i As Long

Set shp(1) = ActiveSheet.Shapes("A")
Set shp(2) = ActiveSheet.Shapes("B")
For Each c In Range("A1:A2")
i = i + 1
Select Case c.Value
Case 1
shp(i).Fill.ForeColor.RGB = RGB(255, 0, 0) '赤
Case 2
shp(i).Fill.ForeColor.RGB = RGB(255, 255, 0) '黄
Case 3
shp(i).Fill.ForeColor.RGB = RGB(0, 128, 0) '緑
Case 4
shp(i).Fill.ForeColor.RGB = RGB(0, 0, 255) '青
Case Else
shp(i).Fill.ForeColor.RGB = RGB(255, 255, 255) '白
End Select
Next
End Sub

回答No.4

watabe007

>例えばセル"A1"には数値の1と"A2"には数値2を入力したら
1を入力したら赤、2を入力したら黄ですね
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape

If Target.Address(0, 0) = "A1" Then
Set shp = ActiveSheet.Shapes("A")
ElseIf Target.Address(0, 0) = "A2" Then
Set shp = ActiveSheet.Shapes("B")
Else
Exit Sub
End If

Select Case Target.Value
Case 1
shp.Fill.ForeColor.RGB = RGB(255, 0, 0) '赤
Case 2
shp.Fill.ForeColor.RGB = RGB(255, 255, 0) '黄
Case 3
shp.Fill.ForeColor.RGB = RGB(0, 128, 0) '緑
Case 4
shp.Fill.ForeColor.RGB = RGB(0, 0, 255) '青
Case Else
shp.Fill.ForeColor.RGB = RGB(255, 255, 255) '白
End Select
End Sub

補足

watabe007様、早速の回答ありがとうございます。

回答の通り、コードを作成したらうまく行けたのですがセルに
計算式が入っていると色が変化しませんでした。

説明不足ですいません。
セル"A1"や"A2"に計算式（関数など）が入っている場合は
どのようにしたらよいでしょうか？
手入力だとオートシェイプの色が変更するのを確認出来ました。

お手数をお掛けして申し訳ありませんm(__)m

回答No.3

SI299792

A1 A2 …に入力すると同時にに色を変更したらいいのですね。
色は書いてある９色です。
オートシェイプが増えても変更する必要はありません。
オートシェイプの順番は、登録した順番です。背面にあるものから順になっています。
前面へ移動、背面へ移動で順番を変えれます。
'
Private Sub Worksheet_Change(ByVal Target As Range)
'
　　If Target.Column > 1 Then
　　　　Exit Sub
　　End If
'
　　On Error Resume Next
　　ActiveSheet.Shapes(Target.Row).Fill.ForeColor.SchemeColor = _
　　　　InStr("黒白赤緑青黄紫水茶", Target) + 7
　　On Error GoTo 0
End Sub
しかし、ネットに乗っているプログラムって、無駄に長いですね。

回答No.2

imogasi

初心者にしては、近道をし過ぎと思う。WEB記事に依存しすぎるとそうなる。
下記のようなコードを一歩一歩やって、納得して、勉強すべきと思う。
ーー
押さえて置くべき色のこと。以前のColorIndexと少し考えが変わっているので。
https://ray88.hatenablog.com/entry/2020/04/25/064457
シートのイベントのことは、お判りでしょう。
ーー
シート上の図形の数捕捉　確認用
Sub test01()
MsgBox Worksheets("Sheet1").Shapes.Count
End Sub
図形とA列セルの対応　確認用
Sub test02()
For i = 1 To Worksheets("Sheet1").Shapes.Count
MsgBox Range("A" & i)
Next i
End Sub
A列の値を変えると（イベント起動）、対応した図形の塗りつぶしの色をセルの値のSchemeColor コードの色に変える。
Private Sub Worksheet_Change(ByVal Target As Range)
n = Target.Row
MsgBox n
Worksheets("Sheet1").Shapes(n).Fill.ForeColor.SchemeColor = Target.Value
End Sub
なお
・A列で、指定した色コードの範囲チェック
・指定セルの範囲チェック
は（課題を盛り込み過ぎないようにするため）省略しているのでよろしく。

回答No.1

asciiz

修正アイデアの一つです。

＞If Target.Address(0, 0) <> "A1" Then Exit Sub

まずこの部分で、「A1じゃなかったらすぐExit」となってしまっているので、逆に「A1だったら以下を実行」に変えます。

---- 変更1 ----
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A1" Then
With ActiveSheet.Shapes("ABC").Fill.ForeColor
Select Case Target.Value
Case Is = "赤"
.SchemeColor = 2
Case Is = "黄"
.SchemeColor = 5
Case Is = "緑"
.SchemeColor = 3
Case Is = "青"
.SchemeColor = 4
Case Else
.SchemeColor = 1
End Select
End With
End If
End Sub
---- ここまで ----

そうしたら、ElseIf節で、「A2だった場合～ DEFシェイプを～」を書き加えられます。

---- 変更2 ----
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A1" Then
With ActiveSheet.Shapes("ABC").Fill.ForeColor
Select Case Target.Value
Case Is = "赤"
.SchemeColor = 2
Case Is = "黄"
.SchemeColor = 5
Case Is = "緑"
.SchemeColor = 3
Case Is = "青"
.SchemeColor = 4
Case Else
.SchemeColor = 1
End Select
End With
ElseIf Target.Address(0, 0) = "A2" Then
With ActiveSheet.Shapes("DEF").Fill.ForeColor
Select Case Target.Value
Case Is = "赤"
.SchemeColor = 2
Case Is = "黄"
.SchemeColor = 5
Case Is = "緑"
.SchemeColor = 3
Case Is = "青"
.SchemeColor = 4
Case Else
.SchemeColor = 1
End Select
End With
End If
End Sub
---- ここまで ----

そうしたらあとは同様に、調べるセルと対象図形を増やしていけます。

ただ、毎回色名と色コードを変換するSelect文が入るのも冗長でしょう。
それなら色名からカラーコードに変換する部分をサブルーチン(関数)化して、

---- 変更3 ----
Function ColorCode(Cname As String) As Integer
Select Case Cname
Case "赤"
ColorCode = 2
Case "黄"
ColorCode = 5
Case "緑"
ColorCode = 3
Case "青"
ColorCode = 4
Case Else
ColorCode = 1
End Select
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A1" Then
ActiveSheet.Shapes("ABC").Fill.ForeColor.SchemeColor = ColorCode(Target.Value)
ElseIf Target.Address(0, 0) = "A2" Then
ActiveSheet.Shapes("DEF").Fill.ForeColor.SchemeColor = ColorCode(Target.Value)
End If
End Sub
---- ここまで ----

こんな風にすれば、対応セルを増やす部分はすごく短く済むでしょう。

…テストしてないので動かなかったらゴメンナサイ

補足

asciiz様

早速の回答ありがとうございます。
変更3で行けたのですが、セル"A1"や"A2"に計算式（関数など）が入っている場合は
どのようにしたらよいでしょうか？
手入力だとオートシェイプの色が変更するのを確認出来ました。

お手数をお掛けして申し訳ありませんm(__)m