ダブルクリックしたセルに数字の入った円形吹き出し図形を挿入したい

Question

VBA初心者です。ご教授願います。

ダブルクリックしたセルに数字の入った円形吹き出し図形を挿入したいです。
また、次にダブルクリックしてセルに図形を挿入したときに中の数字を＋１カウントアップしたいです。（数字は１から始めます）

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim StartX As Single
Dim StartY As Single
Dim EndX As Single
Dim EndY As Single


  With Target

     'Targetの左端
     StartX = .Left

     'Targetの上端
     StartY = .Top

     'Targetの横幅
     EndX = 20
     
     'Targetの高さ
     EndY = 20
     

     '図形挿入
    With ActiveSheet.Shapes.AddShape(msoShapeOvalCallout, StartX, StartY, EndX, EndY)
     
     With .TextFrame.Characters 'テキスト
      
        .Text = "1" '文字列
        .Font.Size = 10 '文字のサイズ
        .Font.Bold = True
        
     End With
     
    End With
    
    Cancel = True

  End With

End Sub

ネットの力を借りて、なんとかダブルクリックしたセルに数字の入った図形を挿入することはできました。

＜問題点＞
1.挿入した図形の色がデフォルトのままです。背景を白、枠線を赤に変えたいです。
2.中の数字が定数”１”のままです。追加するたびにカウントアップするようにしたいです。また、数字を中央にしたいです。
3.新たにシートを追加してもこの処理をできるようにしたいです。

＜可能であれば＞
セルに挿入するだけでなく、クリックした画像にも挿入することは可能でしょうか？

よろしくお願いいたします。

Comments

[meg_]

コードはコード全体を「コードの挿入」で記入していただけませんか。

[Beta]

すみません、変更しました。

[hatena19]

カウントアップは一つのシート内でですか、それともブック全体ですか。
例
シート１で3回ダブルクリック 1、２，３とカウントアップ
その後、シート2でダブルクリックしたら、４からですか、それとも１からですか。

また、シート上にこの円形吹き出し図形以外に図形は存在する可能性はありますか。

ブックを閉じるとき、この図形は残したまま保存しますか。

[Beta]

カウントアップはシート内です。別のシートに移った場合、また1からスタートです。
シート上には四角の図形が存在する場合があります。
ブックを閉じるときは、図形を残したまま保存したいです。

Answer 1

まず、

3.新たにシートを追加してもこの処理をできるようにしたいです。

シートを追加したときにそのシートにイベントモジュールを追加するのは難しいです。
このような時は、THisWorkbook のシートイベントを使います。
これだと全シート共通の処理を一か所で記述できます。
追加したシートでも有効です。
ダブルクリックなら、
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
になります。

カウントアップはシート内です。別のシートに移った場合、また1からスタートです。
シート上には四角の図形が存在する場合があります。
ブックを閉じるときは、図形を残したまま保存したいです。

これでカウントアップするとなると、シート上にある図形をすべてしらべて、円形吹き出し図形のテキストで最大の値を取得する必要があります。これはそのような関数を作成します。

ThisWorkbookモジュール

Option Explicit

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim StartX As Single
    Dim StartY As Single
    Dim EndX As Single
    Dim EndY As Single
    
    Cancel = True

    With Target
        'Targetの左端
        StartX = .Left
        'Targetの上端
        StartY = .Top
        'Targetの横幅
        EndX = 20
        'Targetの高さ
        EndY = 20

        '図形挿入
        With sh.Shapes.AddShape(msoShapeOvalCallout, StartX, StartY, EndX, EndY)
            With .TextFrame
                With .Characters                 'テキスト
                    .Text = GetNextNum(sh)       '文字列
                    .Font.Size = 10              '文字のサイズ
                    .Font.Bold = True
                    .Font.Color = vbBlack         '文字色
                End With
                .HorizontalAlignment = xlHAlignCenter '水平方向中央寄せ
                .VerticalAlignment = xlVAlignCenter   '垂直方向中央寄せ
            End With
            .Line.ForeColor.RGB = vbRed    '枠線色
            .Fill.ForeColor.RGB = vbWhite  '背景色
        End With
    End With

End Sub

Function GetNextNum(sh As Worksheet) As Long
    Dim shp As Shape
    For Each shp In sh.Shapes
        If shp.AutoShapeType = msoShapeOvalCallout Then
            If GetNextNum < Val(shp.TextFrame.Characters.Text) Then
                GetNextNum = shp.TextFrame.Characters.Text
            End If
        End If
    Next shp
    GetNextNum = GetNextNum + 1
End Function

Answer 2