エクセルのマクロで数値に応じてオートシェイプの色を変更したいのですが・

質問

エクセルのマクロで数値に応じてオートシェイプの色を変更したいのですが・・・
マクロは初心者なもので、同じような例を調べて何度も試みたのですが、なかなか思い通りに動くプログラムが作れません。
どなたかマクロに詳しい方、ご教授願えればと思います。
やりたいことは以下の通りです。

シートが２つあります。
Sheet1には210の村について、人口性比のデータが列挙してあります。
Sheet2には、地図の中に、全ての村の所在をオートシェイプで作った○に番号をつけて表示してあります。

マクロを用いてやりたいことは、
Sheet1のG列にある人口性比の数値に応じて、以下の条件を元にSheet2のオートシェイプ（210個すべて）の色を変更させたいのです。
-950以上ならば黄色
-900以上950未満ならば緑
-850以上900未満ならば水色
-800以上850未満ならば青
-800未満ならば紺
というぐあいに。

他のデータに関しても同様に地図上で数値に応じた色分けをしたいので、一つ手本になるものができれば非常に有難いのですが。。

あと、macを使っているのですが、なかなか成功に至らないのはwindowsとのVBAの互換性の問題もあるのでしょうか？？

どなたかアドバイス宜しくお願いします。

回答No.2

lll49erlll · ベストアンサー

macのVBAとの差異については よく分からないのですが、基本的な物については共通だと思ってます。

オートシェイプの扱いには、シェイプの名前の管理がネックになります。
index番号で管理しても「Oval ｎ」のような名前の連番で管理しても　変な数値から始まったり
途中が抜けていたり、コピーなどした場合、変な番号に飛んでいたり、扱いづらいものです。

出来れば H列(あとで非表示にしてもいい)の それぞれの「村」に対応した行にシェイプ名を記入して
おくことを お勧めします。
　シェイプ名はシェイプをクリックしたとき名前ボックス(macでは名前が違うと思うが数式バーの
一番左の枠)に表示される名前です、それをコピーしてH列の対応する「村」の行に貼りつければ
いいと思います、数が多いですが、「村」とシェイプを対応付けるには、それが確実だと思います

それが 出来ていれば簡単な、行をたどるfor～nextかDo～Loop内で処理できます。
例えば、、↓

Sub オートシェイプ色別()

Dim SHP As String 'オートシェイプの名前
Dim COL As Integer '色番号
Dim I As Integer

I = 2 '２行目から始まるとして、、

Do Until Sheets("Sheet1").Cells(I, 8).Value = ""

Select Case Sheets("Sheet1").Cells(I, 7).Value
Case Is >= 950: COL = 13
Case Is >= 900: COL = 17
Case Is >= 850: COL = 15
Case Is >= 800: COL = 12
Case Else: COL = 11
End Select

SHP = Sheets("Sheet1").Cells(I, 8).Value 'H列のシェイプ名を取得
With Sheets("Sheet2").Shapes(SHP).Fill
.Solid
.ForeColor.SchemeColor = COL
End With
I = I + 1　　'１行ごとに「村」の行があるとして、、、
Loop

End Sub

全く実証してませんが一連の流れはこんなもんでいいんじゃないでしょうか。

補足

非常に分かりやすく教えていただき、本当にありがとうございます！
教えていただいた通りにやってみたのですが、実行するとエラーが出てしまいます。Sheet1のE列にOval 797, Oval 892・・・という具合にそれぞれ対応するオートシェイプの番号を表示し、プログラムもCellの列番号を対応するように書き換えた他は教えていただいたものそっくりそのままになっています。
エラーは「プロシージャの呼び出し、または引数が無効です」という表示が出て、デバックをすると「With Sheets("map").Shapes(SHP).Fill」のところが黄色く表示されます。オートシェイプの番号は再度確認したので、どこに問題があるのかわかりません。何かお心当たりの問題があれば、教えていただけると助かります。宜しくお願いします！

回答No.6

lll49erlll

lll49erlll です。

先程 win版 excel 2003で走らせたところ、異常なく実行できました。
　こちらでは、シェイプを選択して名前ボックスに出る「楕円 1」「楕円 2」・・・をコピーして
　セルにペーストしました。

シェイプ名の引数の異常ではないでしょうか？

エラーがでたときのデバッグでエラーが出る上の行の SHP にマウスカーソルを持っていったとき
SHPの値が 正しく表示されるでしょうか？

sub 選択()
ActhiveSheet.Shapes("ここにセルに入れたシェイプ名をペースト").Select
End Sub

↑ 上記のコードを、追加して 実行してたとき、該当のシェイプが選択できるでしょうか
シェイプのあるシートで試して下さい

お礼

大変迅速かつご丁寧な回答をいただいたにも関わらず、お礼をするのが大変遅くなってしまい、本当に申し訳ありません。海外の僻地におり、パソコンの故障も重なってお返事を書けずという状況にあったのですが、結果的に、教えていただいたのに無反応という大変な失礼を致しましたことをお詫び申し上げます。
また、私の稚拙な回答のせいでIII49erIIIさんにもご迷惑をおかけする格好となり、大変申し訳ありませんでした。
問題に関しては、いただいたご回答をもとにやり直したところ、正常に実行できるようになりました。その都度分かりやすくご親切に教えていただき、本当にありがとうございました。No.5のご回答から、私の状況に応じて色々とご配慮をいただいたこと、お忙しい中休憩の時間を私のために費やしていただいたということが分かり、本当に感謝の気持ちで一杯です。ありがとうございました。

回答No.5

lll49erlll

この場を借りて 一言申し上げます。
　いつもながらWendy02さんの ご回答の内容には感銘を受けている一人です。

　　コードを深く読み解くにつれ、技術に裏付けされた心遣いや提示する者の責任などが感じられ、
　私や、質問者に限らず、回答者でも考学の範としている人も多いことと思います。
　これからも我々 稚拙なものへの教示のためにも ここで ご活躍して頂けるよう、お願い致します。

今回はまだまだ 私の稚拙で直感的な考えが 質問者の方に共感を頂けただけだと思いますが、、
私もオートシェイプの扱いに苦労したことがあり、質問者が地図に落としこんである とのことから、
問題のオートシェイプ以外にも 凡例欄や、目印的に四角や三角など、またはエリアを示す大きな丸
など、はたまた矢印とか、、いろいろなオートシェイプを多用してあるのではないかと思い、
直感的に先の内容で提案させていただきました。

ただ、200を超えるオートシェイプ名を手動でコピ・ペさせるには、配慮の無さを感じております
ユーテュリティ的にシェイプを選択したらシェイプ名をセルに取得するようなものを提示すべき
だと思っておりました、
しかし 業務の間のコーヒータイムに直感を頼りに提案させていただいてる者として、精一杯でした
のでヒント的なものだけ載せさせて頂き、失礼いたしました。
　私もこの欄を自分のスキルアップのために大変参考にさせて頂いております、今後ともよろしく
お願いいたします。

質問者の方のエリアをかりて、失礼いたしました。

回答No.4

Wendy02

私は、こちら側のカテゴリはあまり書いてはいませんが、ずっと思ってきたことを、少し筋違いかもしれませんが、書かせてください。

案の定の反応のようです。

>今回lll49erlllさんから教えていただいた方式のほうが私のような度初心者にとっては分かりやすかっため、そちらを採用させていただきました。

私の書く内容に対して、ここのカテゴリの4分の3ぐらいは同じ反応です。だから、最近、ある人には、親切心から、ここの掲示板に、同じような高度な内容の質問は、もう書くのは辞めて専門掲示板に書いたほうがよいと書いたぐらいです。別に、lll49erlllさんを批判しているわけではありません。

#3で書いたように、その人の良かれと思って、いろんな工夫を凝らしたマクロは、コードを書いた人の心遣いが出ているはずです。それが通じるのは、それが分かる人だけです。ただ、おそらく、見ただけで判断しているのだろうと思います。

ここのカテゴリで、日付のエラーを回避するコードを書いたら、私に対して、「自分自身に酔っている」と誹謗中傷した人がいました。読めない人には、その程度にしかありません。場合によって、10行で済むコードが、20行も30行もなることがあります。エラー回避というのは、たかがVBAプログラマでも、上達するためには最低限のルールです。

私が見た感じでは、#2のエラー回避は、少しややこしいように思います。私は、Index処理のほうが楽だと想定していますから、#3のオプションマクロを考えました。それで、どのオートシェイプがどれだと分かるように作られています。それはトグルになっていますから、もう一度実行すれば、元に戻ります。ただ、それは、lll49erlllさんのお考えにお任せすることにします。こちらからは何も言いません。

使う人が、自力でエラー回避出来ない限りは、エラー回避コードを付けてもらわなくてはなりませんが、その分難しくなります。別に皮肉で言っているわけではありませんが、私は、絶対に、初心者向けというようなコードで間に合わせるつもりはありません。それをしたら、こちらがオシマイになってしまいます。許される範囲で、全力で書くということをしなければ、ダメになります。ただし、有償レベルのものは、掲示板では公開しません。法的に、ほとんどのVBAのコードには、著作権を主張できないからです。

一般の人たちは、本格的に書かれたコードなどはまず見ることがありませんが、素人の人が読めるものではないのです。それを可読性という美名で、簡略化したり、コード自体を制限することもありません。

なお、質問さん側から、「採用」「不採用」という言い方は、遠慮してくださるようにお願いします。私は、その言葉が嫌いです。別に、私は、上から目線で、教えているという意識はありませんが、こちらのマクロを、たかが掲示板で、査定されダメ出しされるような立場で臨んでいるわけではないからです。

お礼

しばらく何の反応もできず、大変申し訳ありませんでした。大変時期外れの返事となってしまう失礼をお許しください。海外の僻地にいたため、自分のパソコンの故障のためにしばらく日本語のパソコン環境がなく、このような遅れとなってしまいました。
ご回答を読ませていただき、自分の無知さと安易な返答によってwendy02さんに不愉快な思いをさせてしまったことにようやく気づきました。お時間を割いて私の状況に合わせた綿密なコードを書いていただいたにもかかわらず、そのお心遣いを踏みにじるような安易な発言をしてしまったことに、深くお詫びを申し上げたいと思います。問題の解決を急いでいたとはいえ、質問者としての責任感とイマジネーションに欠けた返答をしてしまったと後悔しております。
ただ、やはり「通じない」側の初心者としては、専門家の方の高度なテクニックに裏打ちされたご配慮はなかなか読み解けないものがあり、「読めない人にはその程度」というご指摘の通りの状況になってしまうのは致し方ないものであるとも思います。その所為でせっかくのご親切を無駄にしてしまうのは本当に申し訳ないのですが、知識の差によるすれ違いが生じてしまうのは少し多めに見ていただけたらと思います。とは言え、今回の私の反応が無礼なものであったことには変わりないので、本当に申し訳ありませんでした。これから少しずつ読めるようになるよう、勉強していきたいと思います。
今後も私のような反応を返してしまう初心者がでてくることは否定できませんが、III49erIIIさんがおっしゃっていたように、wendy02さんのご回答が多くの方にとって大きな助けと学びになっていると思いますので、今回のことでご回答をやめてしまうことのないよう、今後ともぜひ続けていっていただければと思います。
色々と勉強させていただき、ありがとうございました。

回答No.3

Wendy02

#1の回答者です。

#1は、Sheet1 とSheet2の違いが抜けていました。それはミスですが、
初歩的な話ですが、Index とは、順序と同じ意味ですから、番号の抜けなどはありませんが、まあ、#2さんのご指摘の問題に対しては、私は、オプションマクロで対処しようと考えました。

こういう問題は、心遣いの問題で、技術的な問題ではありませんから、通じない人は、何を言っても始まりませんね。

Sub TestMacro1R()
Dim i As Long
Dim iClr As Integer
Dim fig As Integer
Dim rng As Range
Dim sh As Worksheet
Set sh = Worksheets("Sheet2")
With ActiveSheet
Set rng = .Range("G1", .Range("G1000").End(xlUp)) 'オートシェイプは、1000個まで
For i = 1 To sh.Shapes.Count
　 If sh.Shapes(i).Type = msoAutoShape Then
　　　 sh.Shapes(i).Fill.ForeColor.SchemeColor = Fig2Clr(rng.Cells(i))
　 End If
Next
End With
Set rng Nothing
End Sub
Function Fig2Clr(ByVal n As Integer)
Dim iClr As Integer
Select Case n
　Case Is >= 950: iClr = 13
　Case Is >= 900: iClr = 17
　Case Is >= 850: iClr = 15
　Case Is >= 800: iClr = 12
　Case Else: iClr = 11
End Select
　Fig2Clr = iClr
End Function

'//

Sub ShapesIndexChecker()
　'オプション　Index の確認 シェイプのあるシートで実行
　Dim i As Long
　Dim shp As Shape
　For Each shp In ActiveSheet.Shapes
　　With shp
　　　If .Fill.Visible = msoTrue Then
　　　　.Fill.Visible = msoFalse '塗りつぶしなし
　　　　.DrawingObject.Font.Size = 12 'フォントサイズ
　　　　.DrawingObject.Text = shp.DrawingObject.Index
　　　Else
　　　　.Fill.Visible = msoTrue
　　　　.DrawingObject.Text = ""
　　　End If
　　End With
　Next
End Sub

お礼

早速のご回答とともにプログラムを書いていただき、本当にありがとうございます！勉強になりました。
ただ、今回lll49erlllさんから教えていただいた方式のほうが私のような度初心者にとっては分かりやすかったため、そちらを採用させていただきました。せっかくお時間を割いて書いていただいたのに、すみません！ご親切に感謝致します。

回答No.1

Wendy02

>macを使っているのですが、なかなか成功に至らないのはwindowsとのVBAの互換性の問題もあるのでしょうか？？

それは、分からないです。エラーが出ているというならともかく、単なる文章だけでは、無責任に良いとも悪いも言えますが、具体性がないものに確実なことは何もありません。

>オートシェイプ（210個すべて）の色を変更させたいのです。
これは、Index での管理ですから、もしも、名称の管理でしたら、Shapes(i) の部分を

例えば、丸でしたら、このようになります。ただ、["Oval " & i ]で、Oval の後、スペースが空いています。名称は、バージョンによって変わります。

If .Shapes("Oval " & i).Type = msoAutoShape Then
　　.Shapes("Oval " & i).Fill.ForeColor.SchemeColor = Fig2Clr(rng.Cells(i))
End If

'//
Sub TestMacro1()
Dim i As Long
Dim iClr As Integer
Dim fig As Integer
Dim rng As Range
With ActiveSheet
Set rng = .Range("G1", .Range("G1000").End(xlUp)) 'オートシェイプは、1000個まで
For i = 1 To .Shapes.Count
　 If .Shapes(i).Type = msoAutoShape Then
　　.Shapes(i).Fill.ForeColor.SchemeColor = Fig2Clr(rng.Cells(i))
　 End If
Next
End With
End Sub
Function Fig2Clr(ByVal n As Integer)
Dim iClr As Integer
Select Case n
　Case Is >= 950: iClr = 13
　Case Is >= 900: iClr = 17
　Case Is >= 850: iClr = 15
　Case Is >= 800: iClr = 12
　Case Else: iClr = 11
End Select
　Fig2Clr = iClr
End Function