楕円の塗りつぶし

質問

色々と試してはみたのですが、なかなかうまくいきません。

Private Sub Worksheet_Calculate()

For i = 1 To 100

n = (i - 1) * 3 + 8
If Cells(n, "R").Value < -10 Then
c = 10
Else
Select Case Cells(n, "S").Value
Case Is = 0
c = 10
Case Is > -89
c = 17
Case Is < -100
c = 10
Case Else
c = 12
End Select
End If

With Sheets("ABC").Shapes("テキスト " & i)
.Line.ForeColor.SchemeColor = c
.TextFrame.Characters.Font.ColorIndex = c - 7
.TextFrame.Characters.Font.Size = 6
End With

If Cells(n, "W").Value = 37 Then
a = 39
Else
a = 3
End If

With Sheets("ABC").Shapes("楕円 1")
.Fill.ForeColor.SchemeColor = a - 7
.TextFrame.Characters.Font.ColorIndex = a
End With

Next i

End Sub

といった感じで作成しています。
今回
If Cells(n, "W").Value = 37 Then
a = 39
Else
a = 3
End If

With Sheets("ABC").Shapes("楕円 1")
.Fill.ForeColor.SchemeColor = a - 7
.TextFrame.Characters.Font.ColorIndex = a
End With

上記の部分を追加しました。
トラブルだらけです。
読みに行ったセルの値が37なら楕円を39の色にて塗りつぶす、
それ以外なら3です。
ただ、まだ塗りつぶしの色と文字の色の関係は調べていません。

長くわかりづらいと思いますが、宜しくお願いいたします。

回答No.5

Wendy02 · ベストアンサー

こんにちは。

>Range("L11") の１１の部分に変数の n を使用したいのですが、

Range("L" & n).Interior.ColorIndex = 37 Then

もしくは、

Cells(n, 12).Interior.ColorIndex = 37 Then

となります。

お礼

有難う御座いました。

うまくいきました。
最終的には

b = Cells(n, "L").Interior.ColorIndex

If b = 37 Then
a = 46
Else
a = 43
End If

With Sheets("外周(外来波)").Shapes("楕円 " & i)
.Fill.ForeColor.SchemeColor = a
End With

で、色番号37以外はもくっつけました。

変数 b a でややこしくなっていますが、
完成いたしました。

本当に有難う御座いました。

回答No.4

Wendy02

こんにちは。

>他のBOOKよりコピーしてきて貼り付けているのでCalculateにしています。

通常、コピーして張り付ける場合は、Calculate イベントではなくて、Change イベントで十分です。人がマニュアル操作で行わないイベントの場合、Calculate イベントを使います。

Private Sub Worksheet_ChangeByVal Target As Range)

If Intersect(Target, Rows(1)) Is Nothing Then Exit Sub
A列以外に操作した場合は、イベントを除外する。

>テキストボックス・楕円は１００個あります。
そうしたら、書いたり消したりしないほうがよいです。思った以上に、操作する上限が低いのです。たぶん、VRAMメモリとの関係だと思います。数千程度の繰り返しで、オブジェクトが見えなくなったりすることがあります。

>With Sheets("ABC").Shapes("テキスト " & i)
>の部分でインデックスが有効ではないとエラーメッセージが出ます。

この場合は、私が行う方法は、新たに、オートシェイプの名前をマクロ用に付けなおす方法です。

"テキスト " & i というのは、単に、ツールバーのツールボタンでつけた結果だと思います。
スペースが入ったりしています。

'注意：テキストボックスと楕円のインデックス番号が、1 - 1 と連動している場合に限ります。
'もし、連動していない場合は、このマクロは使えません。

'テキストボックスと楕円の再名前付け

Sub ShapesNaming()
　　Dim shp As Shape
　　Dim i As Long, j As Long
　　i = 1: j = 1
　　For Each shp In ActiveSheet.Shapes
　　　　If shp.AutoShapeType = msoShapeOval Then
　　　　　　shp.Name = "Oval" & i
　　　　　　i = i + 1
　　　　End If
　　　　If shp.AutoShapeType = msoShapeRectangle Then
　　　　　　shp.Name = "Text" & j
　　　　　　j = j + 1
　　　　End If
　　Next shp
End Sub

'結果は、楕円 1 ～100 は、Oval1 ～ Oval100, テキスト 1～100 は、Text1～Text100

その上で、

With Sheets("ABC").Shapes("Text" & i) '半角空白が入りません。

With Sheets("ABC").Shapes("Oval" & i)
と書き換えます。

>TextFrame.Characters.Font.ColorIndex = c - 7
>.TextFrame.Characters.Font.Size = 6

これは、コードにエラーが出やすいので、
　.DrawingObject.Characters.Font.ColorIndex = c - 7
　.DrawingObject.Characters.Font.Size = 6

とします。
どうも、変数のc と　aとの関係が見えてきません。コードで分からない部分を言葉で補足して、全体的にコードが見えると良いのですが……。

お礼

有難う御座います。

>通常、コピーして張り付ける場合は、Calculate イベントではなくて、Change イベントで十分です。人がマニュアル操作で行わないイベントの場合、Calculate イベントを使います。

すいません。貼り付けた後にセルの中を色々変更する場合があるので　Calculate イベント　にしています。

>この場合は、私が行う方法は、新たに、オートシェイプの名前をマクロ用に付けなおす方法です。

ある程度動作が確認できてから変更させて頂きます。
なにせ素人なもので、一度に色々変更してしまうと、
どこが悪かったのか判断できなくなってしまいます。

>'注意：テキストボックスと楕円のインデックス番号が、1 - 1 と連動している場合に限ります。
>'もし、連動していない場合は、このマクロは使えません。

連動しています。

>どうも、変数のc と　aとの関係が見えてきません。コードで分からない部分を言葉で補足して、全体的にコードが見えると良いのですが……。

すいません。説明不足で・・・
c は貼り付けをした中のセルの内容によって
テクストボックスを３色に塗り分けるための色の番号です。
a は貼り付けをした中のセルが塗りつぶされていれば楕円を指定色で塗りつぶすための色番号です。
詳しくは下に記載しました。

宜しくお願いします。

補足

色々、試してみました。
とりあえず、マクロ関数というのですかね。
怪しそうなので、別の手を考えて

If Range("L11").Interior.ColorIndex = 37 Then
With Sheets("ABC").Shapes("楕円 " & i)
.Fill.ForeColor.SchemeColor = 46
End With
End If

と変えてみました。
エラーも消え、塗りつぶしも動作しました。
ただ、　Range("L11") の１１の部分に変数の n を使用したいのですが、
記載方法が解りません。
Range("L", n)でエラーになります。
もう少しと近づいた感じです。

宜しくお願いいたします。

回答No.3

okazu-san

> With Sheets("ABC").Shapes("テキスト " & i)

ここでインデックスが有効範囲ではないと出るのは、
シート名"ABC"がないことが考えられますね。

お礼

有難う御座います。

何度も確認したのですが、名前は合っています。
今までは使っていました。
今回の追加にてエラーが出るようになりました。
今回追加した部分ではなく、
今まで使っていた部分です。

色々試したのですが、
今回L列のセルの色を判断し、（判断といっても塗りつぶされているかいないかです）
色がついていたら楕円を決められた色で塗りつぶす。
といったことを実行したいのです。
塗りつぶしがあるかどうかの方法がわからなかったので、
挿入→名前→定義にて、「CELLCOLOR」というものを作りました。
=GET.CELL(63,$L8)+NOW( )*0
W列に　=CELLCOLOR　にて、L列の色番号を拾ってきています。
実際に塗りつぶされていた色は３７でした。

この定義の部分を設定するとエラーが発生するようになります。
これを削除し、W列に直接３７を入力するとエラーは起こりませんでした。

遅くなりましたが、EXCEL2003を使用しています。

回答No.2

Wendy02

こんばんは。

コードが良く分からない部分があります。
Shapes の置いてある場所と、アクティブシートとは別なのでしょうか？
なぜ、Calculate イベントという忙しいイベントにしているのかも良く分かりません。
Change イベント程度で十分ではないでしょうか。OLEでデータをインポートしているのでしょうか？
テキストボックスは、100もあるのでしょうか。余計なことかもしれませんが、ワークシートのつくりとして、全体的に無理はないでしょうか？

それと、
With Sheets("ABC").Shapes("楕円 1")
こういう、割り付けはループの中では無理です。ひとつのオブジェクトに100回も同じようなことをさせても、無駄だと思います。

If Cells(n, "W").Value = 37 Then
a = 39
Else
a = 3
End If

a の値が、3と出て、
.Fill.ForeColor.SchemeColor = a - 7 '*
.TextFrame.Characters.Font.ColorIndex = a
では、マイナスになれば、エラーが出ます。
SchemeColor は、ColorIndex に7を足すと出ます。だから、"a +7" でしょうけれども、塗りつぶしと同じフォントの色にしたら見えないと思います。

お礼

ご回答有難う御座います。

Shapes の置いてある場所と、アクティブシートとは別なのでしょうか？
あまり詳しくないのでわかりませんが、コードの書いてあるシートと楕円のあるシートは別です。

他のBOOKよりコピーしてきて貼り付けているのでCalculateにしています。

テキストボックス・楕円は１００個あります。
実際いつも１００個使うわけではないのですが、基本シートとして作ってあります。

ここにきて間違いを発見しました。
楕円も１００個なので、ループしています。
１→iに直します。

補足

色々試してみましたが、うまくいきませんでした。

If Cells(n, "W").Value = 37 Then
a = 39
Else
a = 36
End If

With Sheets("ABC").Shapes("楕円 " & i)
.Fill.ForeColor.SchemeColor = a + 7
End With

と直してみました。
すると、ここではない
With Sheets("ABC").Shapes("テキスト " & i)
の部分でインデックスが有効ではないとエラーメッセージが出ます。
テクストボックスの数も１００個あります。
以前は問題なく動作していました。
今回の部分の追加にて発生しました。

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

回答No.1

okazu-san

> If Cells(n, "W").Value = 37 Then
> a = 39
> Else
> a = 3
> End If
>
> With Sheets("ABC").Shapes("楕円 1")
> .Fill.ForeColor.SchemeColor = a - 7
> .TextFrame.Characters.Font.ColorIndex = a
> End With

上記の内容ですと、aが3になっている場合、

> .Fill.ForeColor.SchemeColor = a - 7

この一文を通過するときに、「-4」になってしまうため、
この部分でエラーが出ると思いますよ。
どのようなことを行いたいのかがわからないので、適切な回答では
ないかもしれませんが、If文の中に入れるなどした方がよさそうです。

お礼

有難う御座います。
全然気づいていませんでした。
まだ試していませんが、とりあえずお礼まで

今回やりたいことは、
実際にはセルに色がついていたら、
楕円をある色で塗りつぶす。
それ以外ならまたある色で塗りつぶす。
その楕円が１００個あります。

セルに色がついていたらという使い方がわからなかったので
セルの色を”GET.CELL(63,$A1)+NOW( )*0"で
色の番号を拾ってきてセルの内容がその番号だったら
楕円を塗りつぶすにしています。

とりあえず a-7　を直してみます。

有難う御座います。