複数セルに〇印をつけるマクロ

現在下記のマクロで複数セルに一度に〇印（楕円）をつける作業をしています。
やりたいこと
①セルの幅に合わせて〇をつける（楕円ではなく円）・・・縦長のセルのため
②結合したセルには一つの〇（円）が描かれるようにする（現在はセル数分〇印が描かれてしまう）。
以上です。どなたか記述を修正していただけませんでしょうか。

Sub 　選択した複数セルに〇印()
For Each r In Selection
Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
s.Fill.Visible = msoFalse
s.IncrementLeft 0
s.IncrementTop 0
With s.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
Next
End Sub

No.4 ベストアンサー 回答者： fujillin 回答日時： 2022/09/07 13:47

こんにちは

＞①セルの幅に合わせて〇をつける
「幅」に合わせるという決め打ちで良いのなら、No1様の回答にある通り、サイズを幅で決めるようにすればよいです。
セル形状が不明の場合は、縦横の小さい方の値を採用すれば宜しいでしょう。
表示位置をどこにするのかご質問文にないのではっきりとしませんが、左上合わせとか中央合わせとかはサイズを決めてから計算すれば良いでしょう。

＞②結合したセルには一つの〇（円）が描かれるようにする
For Eachでループさせているので、結合セルの場合はその構成セル数分だけループすることになりますので、現状のままだとその個数分描かれることになります。
仮に結合セルが無くても、複数のセル範囲を重なりがあるように選択してループすると、重なっている部分は重複してカウントされるので、同様のことが発生します。

これを回避するには、選択セルの内容を解析して（結合セルを含め）重複が無いようにしてからループすれば良いですが、解析するのが結構面倒ですね。
代替案として、（効率はやや落ちますが）「セル内の作成された円」を削除してから円を描くようにすれば、結果的に必ずひとつだけ残ることになります。

以下は、そのような方法での一例です。
※ 作成する円は、セルに対して中央合わせにしてあります。
※ 非表示セルには図形を描けないので、非表示セルは飛ばしています。
　（一旦、表示してから描けば描けますけれど・・）
※ 当該マクロで作成した図形以外の図形はそのまま残ります。
※ 選択内容がセル範囲ではない場合には何もしません。

Sub Sample()
Dim r As Range, c As Range, s As Shape
Dim x As Single, y As Single, z As Single

If TypeName(Selection) <> "Range" Then Exit Sub

For Each r In Selection.Cells
If Not (r.EntireRow.Hidden Or r.EntireColumn.Hidden) Then
Set c = r.MergeArea

For Each s In ActiveSheet.Shapes
If Not Intersect(c, Range(s.TopLeftCell, s.BottomRightCell)) Is Nothing Then
If s.AlternativeText = "HOGE_OVAL" Then s.Delete
End If
Next s

z = Application.Min(c.Width, c.Height) - 2
x = c.Left + (c.Width - z) / 2
y = c.Top + (c.Height - z) / 2

With ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, z, z)
.Fill.Visible = msoFalse
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Transparency = 0
.Line.Weight = 1.5
.AlternativeText = "HOGE_OVAL"
End With
End If
Next r
End Sub

この回答へのお礼

本当にありがとうございます。懇切丁寧なご説明までいただき感謝申し上げます。一つづつ調べながら理解しようと努めているところです。
思った通りに〇印を書くことができ大変助かりました。

お礼日時：2022/09/07 22:19

No.3 回答者： Qchan1962 回答日時： 2022/09/07 12:34

＃2です

動くけれど違うようなので訂正
Dim wh As Double

Property Height As Single
Excel.Shape のメンバー　なので
Dim wh As Single

Set r = r.MergeArea
ループに使っているRangeオブジェクトを再セットは良くないかも知れません
新たに　Rangeオブジェクト変数をたてる方が好ましいと思います

No.2 回答者： Qchan1962 回答日時： 2022/09/07 12:23

こんにちは

ちょっと改造して

Sub 選択した複数セルに〇印()
Dim r As Range, s As Shape
Dim wh As Double
For Each r In Selection
If r.Address = r.MergeArea(1).Address Then
Set r = r.MergeArea
wh = WorksheetFunction.Min(r.Width, r.Height)
Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, r.Left, r.Top, wh, wh)
s.Left = r.Left + (r.Width - s.Width) / 2
s.Top = r.Top + (r.Height - s.Height) / 2
s.Fill.Visible = msoFalse
s.IncrementLeft 0
s.IncrementTop 0
With s.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
End If
Next
End Sub

If r.Address = r.MergeArea(1).Address Then
Set r = r.MergeArea
この書き方は調べてみてください

この回答へのお礼

ありがとうございます。思った通りに動き、〇の位置もベストでした。
感謝申し上げます。

お礼日時：2022/09/07 22:16

No.1 回答者： めぐみん_ 回答日時： 2022/09/07 08:05

＞AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)

高さも横幅で指定する。

AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Width)