Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2458 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【67915】オートシェイプのマイナス作成について Imai 11/1/16(日) 23:43 質問[未読]
【67916】Re:オートシェイプのマイナス作成について 山猿 11/1/17(月) 0:01 発言[未読]
【67917】Re:オートシェイプのマイナス作成について kanabun 11/1/17(月) 0:24 発言[未読]
【67919】Re:オートシェイプのマイナス作成について kanabun 11/1/17(月) 10:02 発言[未読]
【67923】Re:オートシェイプのマイナス作成について Imai 11/1/17(月) 12:05 質問[未読]
【67915】オートシェイプのマイナス作成について
質問  Imai  - 11/1/16(日) 23:43 -
引用なし
パスワード
   オートシェイプを使って横棒で長さを表示するようにしていきたいのですが(いわば棒グラフ的）、Cells(6,10)の数字を元にプラスとマイナスに出したいのですが、マイナス方向が出ません。コードに関してご指摘いただけませんでしょうか。
そして、更に、先に書かれたシェイプを削除する方法も分からず、オートシェイプが何重にも重なってしまいます。直し方を教えてください。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
With Sheets(1)
.Cells(6, 10).Shapes("四角形", .Left, .Top).Delete
End With
On Error GoTo 0
Dim sp
With Sheets(4).Cells(7, 10)
If Cells(6, 10) > 0 Then
Set sp = Sheets(1).Shapes.AddShape(msoShapeRectangle, _
　　　　　　　　　　 .Left, .Top, Cells(6, 10).Value * 0.2, 14)
sp.Fill.ForeColor.SchemeColor = 3
Else　'マイナスの場合
Set sp = Sheets(1).Shapes.AddShape(msoShapeRectangle, _
　　　　　　　　　　 .Left, .Top, Cells(6, 10).Value * -0.2, 14)
End If
End With
End Sub
【67916】Re:オートシェイプのマイナス作成について
発言  山猿  - 11/1/17(月) 0:01 -
引用なし
パスワード
   ▼Imai さん：
>オートシェイプを使って横棒で長さを表示するようにしていきたいのですが(いわば棒グラフ的）、Cells(6,10)の数字を元にプラスとマイナスに出したいのですが、マイナス方向が出ません。コードに関してご指摘いただけませんでしょうか。

幅がマイナスというのはダメだから、Leftをその分左に移動するんじゃ
ないですか、普通に考えて。

>そして、更に、先に書かれたシェイプを削除する方法も分からず、オートシェイプが何重にも重なってしまいます。直し方を教えてください。
>With Sheets(1)
>.Cells(6, 10).Shapes("四角形", .Left, .Top).Delete
>End With
気持ちはわかりますが、そういうことはできません。
Shapeはセルが管理しているものじゃないです。
すべてのShapeのTopLeftCellなどを調べて、削除対象かを判定する必要があります。
【67917】Re:オートシェイプのマイナス作成について
発言  kanabun  - 11/1/17(月) 0:24 -
引用なし
パスワード
   ▼Imai さん：

>オートシェイプを使って横棒で長さを表示するようにしていきたいのですが
> (いわば棒グラフ的）、Cells(6,10)の数字を元にプラスとマイナスに出したい
> のですが、マイナス方向が出ません。

>そして、更に、先に書かれたシェイプを削除する方法も分からず、
>オートシェイプが何重にも重なってしまいます。直し方を教えてください。

削除の方法は、図形を挿入したら、名前を付けておけば、
つぎに描画するとき、その名前の図形を削除すればいいですよね？

それから、どのイベントを使うか、ですが、
[J6]セルの値が変化したら、ということで Changeイベントではいかがですか？

Private Sub Worksheet_Change(ByVal Target As Range)
　If Target.Address(0, 0) <> "J6" Then Exit Sub
　On Error Resume Next
　　Me.Shapes("myBar").Delete　 '「myBar」という名前の図形を消す
　On Error GoTo 0

　Dim Value
　Value = Range("J6").Value * 0.2
　Select Case Value
　　Case Is > 0
　　　With Range("J7")
　　　　　With Me.Shapes.AddShape(msoShapeRectangle, _
　　　　　　　　　　　 .Left, .Top, Value, 14)
　　　　　　　.Fill.ForeColor.SchemeColor = 3
　　　　　　　.Name = "myBar"
　　　　　End With
　　　End With
　　　　
　　Case Is < 0 'マイナスの場合
　　　With Range("J7")
　　　　　With Me.Shapes.AddShape(msoShapeRectangle, _
　　　　　　　　　　　 .Left + Value, .Top, -Value, 14)
　　　　　　　.Fill.ForeColor.SchemeColor = 5
　　　　　　　.Name = "myBar"
　　　　　End With
　　　End With
　End Select

End Sub
【67919】Re:オートシェイプのマイナス作成について
発言  kanabun  - 11/1/17(月) 10:02 -
引用なし
パスワード
   すこし修正
　　Shapes.Add　→ Rectangles.Add

Private Sub Worksheet_Change(ByVal Target As Range)
　If Target.Address(0, 0) <> "J6" Then Exit Sub
　On Error Resume Next
　　Me.Rectangles("myBar").Delete
　On Error GoTo 0

　Dim Value
　Dim Left#, Width#
　Dim Color As Long
　
　Value = Range("J6").Value * 0.2
　With Range("J7")
　　　Select Case Value
　　　　Case Is > 0
　　　　　　Left = .Left
　　　　　　Width = Value
　　　　　　Color = 4
　　　　Case Is < 0 'マイナスの場合
　　　　　　Left = .Left + Value
　　　　　　Width = -Value
　　　　　　Color = 3
　　　　Case Else
　　　　　　Exit Sub
　　　End Select
　　　With Me.Rectangles.Add(Left, .Top, Width, 14)
　　　　　.Interior.ColorIndex = Color
　　　　　.Name = "myBar"
　　　End With
　End With

End Sub
【67923】Re:オートシェイプのマイナス作成について
質問  Imai  - 11/1/17(月) 12:05 -
引用なし
パスワード
   ▼kanabun さん：
大変ありがとうございました。オートシェイプの表現を諦めなければ…っと思っていました。セルの間隔を短くして、色セルの長さで横棒グラフを代用していましたが、四捨五入処理をしてセルを埋めるか・空けるかで細かい長さが表現できませんでした。
それから、このようなことが出来るので有れば、オートシェイプの複数個(６ヶ）に「写真を削除・挿入し写真のナンバー付け」が以下のコードでうまくいきました。

On Error Resume Next
With ActiveSheet
　　For k = 1 To 6
　　.Rectangles("myPicture" & k).Delete
　　Next k
End With
On Error GoTo 0
非常にありがたく感謝しています。と共に、次はいつも同じ写真であれば問題が無いのですが、写真を変更したときには、ナンバー付けが生かされない…という問題が出てきそうです。これは今すぐではありませんのでまた、その時には質問させていただきます。
このテーマは着眼点を変えてみる必要が在るのでしょうか。
　　
それから、
山猿さん　ありがとうございました。分かりにくい質問でご迷惑をおかけしました、今後ともよろしくお願いします。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2458 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free