マクロで、選択セルの直近にオブジェクト（オートシェイプ）を作成したい

質問

お世話になります。エクセルマクロのまだまだ初心者です。
エクセルで、５列×２５行ほどのセル範囲における作業ですが、そのなかのいくつかに文字が入力されています。どこのセルにいくつ入力されるかは常に変化します。その、入力されている全てのセルのすぐ近くに、一定の大きさのオートシェイプ（吹き出し）を作成したいのです。
入力されているセルを選択することと、オートシェイプを作るマクロは、
Range("A1:D25").Select
Selection.SpecialCells(xlCellTypeConstants, 2).Select
’吹き出しの作成
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, 165#, 61.5, _
105.75, 56.25).Select
Selection.Characters.Text = "Hello World!"
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.FontStyle = "標準"
.Size = 9
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
.Orientation = xlHorizontal
End With
こんな感じに作れましたが、選択セルのすぐ近くという位置取りがどう調べても分かりません。
位置は、セルの上下左右どこでもいいのですが、そのセルを説明するように吹き出しを入れたいのです。
良い方法があるでしょうか。
よろしくお願いします。

回答No.3

mitarashi · ベストアンサー

#1です。鏡餅状態になりますが、適宜調整してください。
Sub Macro3()
Dim myCell As Range, targetRange As Range
If TypeName(Selection) <> "Range" Then Exit Sub
Set targetRange = Selection
For Each myCell In targetRange
ActiveSheet.Shapes.AddShape(msoShapeOvalCallout, myCell.Left + myCell.Width * 1.5, myCell.Top + myCell.Height / 2, 70, 25). _
Select
Selection.Characters.Text = "Hello World!"
Selection.Font.Size = 8
Selection.ShapeRange.Adjustments.Item(1) = -0.5
Selection.ShapeRange.Adjustments.Item(2) = 0
Next myCell
End Sub

お礼

すごいです。完璧です。
早く自分でもこのように記述できるようになりたいです。どのように勉強されたのでしょうか。できればアドバイス下さい。
本当に、ありがとうございました。

回答No.2

imogasi

シートのSelectionChangeイベントに（ただしお勧めは後記）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
l = Target.Left + Target.Width + 10
t = Target.Top + 10
w = 100
h = 60
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, l, t, _
w, h).Select
Selection.ShapeRange.Adjustments.Item(1) = -0.1716
Selection.Characters.Text = "Hello World!"
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.FontStyle = "標準"
.Size = 9
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
.Orientation = xlHorizontal
End With
Selection.ShapeRange.Adjustments.Item(1) = -0.1
Selection.ShapeRange.Adjustments.Item(2) = -0.1
End Sub
l,t,w,hの値は適当に試行錯誤で修正のこと。
Adjustments.Item(1)
Adjustments.Item(2)
のことは私も良くわかってない。シェイプを選択したとき現れる黄色小四角の位置を決めるものと思っている。
（１）のマイナスは左へ修正、
（２）のマイナスは上へ、
を示すようだ。
ーーーーーー
SelectionChangeイベントはシートをアクチブにしてセルを選択すると
すぐ効果が始まり、うっとうしい。またいつまでも続いてしまう。
だからトリガーとなるボタンをシートに１つ設けて、そのClickイベントに上記の中身を入れるのが良さそう。
その場合TargetはSelectionに書き直すこと。
Private Sub CommandButton1_Click()
Set Target = Selection
l = Target.Left + Target.Width + 10
t = Target.Top + 10
w = 100
h = 60
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, l, t, _
w, h).Select
Selection.ShapeRange.Adjustments.Item(1) = -0.1716
Selection.Characters.Text = "Hello World!"
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.FontStyle = "標準"
.Size = 9
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
.Orientation = xlHorizontal
End With
Selection.ShapeRange.Adjustments.Item(1) = -0.1
Selection.ShapeRange.Adjustments.Item(2) = -0.1
End Sub

補足

早速のご回答ありがとうございます。
教えていただいたものが、ほぼ目的のものですが、残念ながらオートシェイプが一つしかできません。私は、選択範囲で選択された複数のセルすべてに付けたいのです。
SelectionChangeイベントに入れるのも、ご指摘のとおり少々難があります。

再度、ご教示いただけないでしょうか。

回答No.1

mitarashi

吹き出しの種類が違うかもしれませんが、ご参考まで。位置の決め方はあくまで参考ですので、お好きにアレンジしてください。
Dim myCellを宣言して使っているのは、インテリセンス機能が、オブジェクト（ここではセル）がどの様な属性を持っているのか表示してくれる様にしているものです。手で打ち込んでもらえると、ご理解いただけると思います。Adjustments.Itemのところは試行錯誤で入れた数字です。
Sub Macro2()
Dim myCell As Range

Set myCell = ActiveCell
ActiveSheet.Shapes.AddShape(msoShapeOvalCallout, myCell.Left + myCell.Width * 1.5, myCell.Top + myCell.Height / 2, 70, 25). _
Select
Selection.Characters.Text = "Hello World!"
Selection.Font.Size = 8
Selection.ShapeRange.Adjustments.Item(1) = -0.5
Selection.ShapeRange.Adjustments.Item(2) = 0
End Sub

補足

早速のご回答ありがとうございます。
教えていただいたものが、ほぼ目的のものですが、残念ながらオートシェイプが一つしかできません。私は、選択範囲の選択セルすべてに付けたいのです。
Set myCell = ActiveCell
のところを、Selectionに変えてみましたができません。
再度、ご教示いただけないでしょうか。