Excel VBA素人です。VBAで図形のセンタリング方法ご教示下さい

Excel　VBA素人です。VBAで図形をセンタリングする為のコードご存じの方教えてください。

C1:G8には文字（アルファベット）が入っています。
文字を検索し「A」のみの中央に図形の「〇」（※緑色）を付けたく、以下のコードを作ってみましたが、添付の写真のように、セルの中央に「〇」が付きません。Forループを使わない場合は上手くいくのですが。（尚、図形削除のボタンは無視してください）
図形を文字中央に移動するために必要なコード（Forループ内で）をご教示ください。
以下現状のコードです。

Sub まる()
Dim n As Integer
Dim d As Integer
s = 0
For d = 1 To 5
For n = 3 To 8
If Cells(d, n) = "A" Then
ActiveSheet.Shapes("まる").Copy
Cells(d, n).Select
ActiveSheet.Paste
End If
Next n
Next d
End Sub

素人ですので丁寧なご指導をお願いいたします。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2023/09/19 13:17

こんにちは

Duplicate メソッド を使用した理想的な回答がされていますし
解決されているので余計な回答ですが

初心者との事で示されているコードに付け加え処理できる方法も回答します

貼り付けたShapeを取得する方法です
べたな方法も記憶に留めておくと良いかも知れません

Sub まる1()
Dim n As Integer
Dim d As Integer
s = 0
For d = 1 To 5
For n = 3 To 8
If Cells(d, n) = "A" Then
ActiveSheet.Shapes("まる").Copy
Cells(d, n).Select
ActiveSheet.Paste
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.Left = Cells(d, n).Left + (Cells(d, n).Width - .Width) / 2
.Top = Cells(d, n).Top + (Cells(d, n).Height - .Height) / 2
End With
End If
Next n
Next d
Cells(d, n).Select
End Sub

追加部分
貼り付けたShapeに対して位置を指定
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.Left = Cells(d, n).Left + (Cells(d, n).Width - .Width) / 2
.Top = Cells(d, n).Top + (Cells(d, n).Height - .Height) / 2
End With

終了時のShape選択解除
Cells(d, n).Select

諸々で処理手順として60点くらいかも・・・ですが
ActiveSheet.Shapes(ActiveSheet.Shapes.Count)は使う場面があるかも知れませんね

この回答へのお礼

返信が遅れました事お詫びいたします。
素人の私には、このコードが解りやすく今後、他の人がメンテするにしてもメンテ性が良いと感じます。今後ご指導を乞うことが有ろうかと思いますがその時にはよろしくお願いいたします。ありがとうございました。

お礼日時：2023/09/20 17:07

No.1 回答者： fujillin 回答日時： 2023/09/19 12:13

こんにちは

セルや図形の中央を表す属性は無いので、左、上と高さ、幅などから計算します。
例えば、水平方向なら
　図形.Left + 図形.Wifth /2
みたいな感じです。
それぞれの水平・垂直の中央位置が一致するように配置すれば良いことになります。


※ 図形名称「まる」という図形がシート上に存在し、それをコピーして
　使用するという条件で良いものと解釈しました。
以下のような感じでできませんか？

Sub Q13599304()
Dim sp As Shape, c As Range

Const targetRange = "C1:G8" ' 対象セル範囲
Const shapeName = "まる" ' 図形名称


For Each sp In ActiveSheet.Shapes
If sp.Name = shapeName Then Exit For
Next sp
If sp Is Nothing Then MsgBox "図形がありません": Exit Sub

For Each c In Range(targetRange)
If c.Text = "A" Then
With sp.Duplicate
.Top = c.Top + (c.Height - .Height) / 2
.Left = c.Left + (c.Width - .Width) / 2
End With
End If
Next c
End Sub

この回答へのお礼

早速の返信ありがとうございます。
素晴らしい。完璧です。勉強になりました。ありがとう御座いました。また何かありましたらご教示をお願いいたします。

お礼日時：2023/09/19 12:26