『選択した行に楕円が表示されない』（東九）
Sheet2 ※丸付き数字の丸は楕円で囲んだものとします。
|[A] |[B]
[1]| ➀ りんご ➁ パイナップル ➂ バナナ ➃ なし ➄ サクランボ |
[2]| １ りんご ２ パイナップル ３ バナナ ４ なし ５ サクランボ |
[3]| １ りんご ２ パイナップル ３ バナナ ４ なし ５ サクランボ |
[4]| １ りんご ２ パイナップル ３ バナナ ４ なし ５ サクランボ |
[5]| １ りんご ２ パイナップル ３ バナナ ４ なし ５ サクランボ |
楕円データ
|[A] |[B] |[C] |[D] |[E]
[1]|番号|左位置|上位置|幅 |高さ
[2]| 1| 6.09| 4.16|16.92|19.42
[3]| 2| 73.37| 4.16|16.92|19.42
[4]| 3|186.66| 4.16|16.92|19.42
[5]| 4|253.94| 4.16|16.92|19.42
[6]| 5|305.38| 4.16|16.92|19.42
Sheet2のA1にある楕円の位置を取得したものが楕円データです。
楕円の位置を取得したら楕円を削除します。
指定した番号に楕円で囲むマクロを作成しました。
どの行を選択してもA1に楕円が表示されます。
選択した行に楕円を表示するにはどのようにしたらいいでしょうか。
Sub 番号で楕円表示()
Dim 情報シート As Worksheet
Dim 作業シート As Worksheet
Dim 番号 As Long
Dim 行番号 As Long
Dim 楕円 As Shape
Dim 基準セル As Range
Dim 図形 As Shape
Dim 左位置 As Double
Dim 上位置 As Double
Dim 幅 As Double
Dim 高さ As Double
Set 情報シート = Worksheets("楕円データ")
Set 作業シート = ActiveSheet
' 現在のアクティブアクティブセルを基準に描画
Set 基準セル = ActiveCell
' 番号入力
番号 = val(InputBox("番号を入力してください"))
If 番号 = 0 Then Exit Sub
' 番号検索
行番号 = 2
Do While 情報シート.Cells(行番号, 1).Value <> ""
If 情報シート.Cells(行番号, 1).Value = 番号 Then Exit Do
行番号 = 行番号 + 1
Loop
If 情報シート.Cells(行番号, 1).Value = "" Then
MsgBox "番号が見つかりません"
Exit Sub
End If
' 楕円データシート情報取得
左位置 = 情報シート.Cells(行番号, 2).Value
上位置 = 情報シート.Cells(行番号, 3).Value
幅 = 情報シート.Cells(行番号, 4).Value
高さ = 情報シート.Cells(行番号, 5).Value
' 同じセルの楕円削除
For Each 図形 In 作業シート.Shapes
If 図形.Name Like "選択楕円*" Then
If 図形.TopLeftCell.Address = 基準セル.Address Then
図形.Delete
End If
End If
Next 図形
' 楕円描画
Set 楕円 = 作業シート.Shapes.AddShape( _
msoShapeOval, 左位置, 上位置, 幅, 高さ)
楕円.Name = "選択楕円" & 番号 & "_" & 基準セル.Address(False, False)
楕円.Fill.Visible = msoFalse
楕円.Line.ForeColor.RGB = RGB(255, 0, 0)
楕円.Line.weight = 1
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
なんか楕円データの上位置が全部4.16ですけど?
（白茶） 2026/10/20(火) 23:02:38
(言葉足らずでした^^;)
つまり、情報シートにはもっと続きがあるのかな? それとも、最初の行の情報だけしな用意してない前提で、マクロ側をどうすれば良いのか? って話なのかな?
と、思って訊いただけです。
（白茶） 2026/10/20(火) 23:12:53
＞もっと続きがあるのかな?
増減します。
＞マクロ側をどうすれば良いのか?
なにか追加するとしたらどのようになりますか
（東九） 2026/10/21(水) 00:05:38
ざっと眺めてみただけの意見ですが、
上位置 = 情報シート.Cells(行番号, 3).Value の結果、上位置は固定的に「4.16」になってるだけですから、 どこかのタイミングで選択した行の縦位置(基準セル.Top とか?)を加えてあげればイイのでは...
って感じに見えました。
（白茶） 2026/10/21(水) 08:38:29
＞どの行を選択してもA1に楕円が表示されます。
それは「楕円データ」の「上位置」が全部同じでかつ 4.16 という小さな数字なのだから、（A 列かどうかはともかく）1 行目あたりに描かれるでしょうね。
（4xmy） 2026/10/21(水) 08:47:10
＞どの行を選択してもA1に楕円が表示されます。
↑意味が分からん？？？
（名無し） 2026/10/21(水) 09:40:04
（名無し） 2026/10/21(水) 09:51:12
Set 楕円 = 作業シート.Shapes.AddShape( _
msoShapeOval, 左位置, 上位置, 幅, 高さ)
上記の命令で、「上位置」というのが、セル内でのTopと勘違いされていませんか。
「作業シート.Shapes.AddShape」なので
「作業シートにShapeをAddShape」しなさい。
つまり、シートの上からの位置です。
ではセルのTopでやってみたらどうなるか。
以下のコードを新規Bookで試してみてください。
Sub test()
Dim ws As Worksheet
Dim rng As Range
Dim sh1 As Shape
Dim sh2 As Shape
Set ws = Worksheets("sheet1")
Set sh1 = ws.Shapes.AddShape(msoShapeOval, 10, 10, 10, 10)
Set rng = Range("B3")
Set sh2 = rng.Shapes.AddShape(msoShapeOval, 10, rngTop, 10, 10) 'ここでエラーが出る
End Sub
オブジェクトはプロパティまたはメソッドーをサポートしていません
というえらが出ます。
これは、セル(Rangeオブジェクト)には、Shapes(図形)を書くことはできない
という事です。
従って、セル(Rangeオブジェクト)のTopプロパティが、
SheetsオブジェクトのTopプロパティになるかを指定する必要があります。
Sub test2()
Dim ws As Worksheet
Dim rng As Range
Dim sh1 As Shape
Dim sh2 As Shape
Dim rngTop As Double
Set ws = Worksheets("sheet1")
Set sh1 = ws.Shapes.AddShape(msoShapeOval, 10, 10, 10, 10)
Set rng = Range("B3")
rngTop = rng.Top
Set sh2 = ws.Shapes.AddShape(msoShapeOval, 10, rngTop, 10, 10)
End Sub
という感じです。
（匿名） 2026/10/21(水) 10:24:03
基準セルの位置に応じて、変数「上位置」の値が変わらないと、 楕円を描く場所は変わりませんよ、という話ですね
' 楕円描画
Set 楕円 = 作業シート.Shapes.AddShape( _
msoShapeOval, 左位置, 基準セル.TOP , 幅, 高さ)
にすればいいのかな？ （実行確認してません） （´・ω・`） 2026/10/21(水) 11:48:07
＞間違っていたらすみません。
気を使ってもらって有難うございます。
＞どこかのタイミングで選択した行の縦位置(基準セル.Top とか?)を加えてあげればイイのでは...
＞ にすればいいのかな？
選択行に表示されるようになりました。
上位置が反映されないので「TOP+4.16」としました。
有難うございました。
（東九） 2026/10/21(水) 16:39:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.