Excelで選択セルに楕円を描画する

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case Target.Address
Case "$Q$45:$R$45"
ClickSel1 1, Target, "AI45"
Case "$V$45:$W$45"
ClickSel1 1, Target, "AI45"
End Select
End Sub

' 楕円の描写　　Module
Public Sub ClickSel1(no As Integer, Target As Range, rng As String)
On Error GoTo ErrorTrap

Dim neme As String
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim Shape1 As Object
Dim Shape3 As Object

neme = "WA"
For Each Shape3 In ActiveSheet.Shapes
If Shape3.Name = neme + CStr(no) Then
If Shape3.Top = Range(Target.Address).Top + 2 And Shape3.Left = Range(Target.Address).Left + 2 Then
Shape3.Delete
Else
Shape3.Top = Range(Target.Address).Top + 2
Shape3.Left = Range(Target.Address).Left + 2
End If
ActiveSheet.Range(rng).Select
Exit Sub
End If
Next

' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(Target.Address)
SentakuTop = .Top + 2
SentakuLeft = .Left + 2
SentakuWidth = .Width - 4
SentakuHeight = .Height - 4
End With
Set Shape1 = ActiveSheet.Shapes.AddShape(msoShapeOval, SentakuLeft, SentakuTop, SentakuWidth, SentakuHeight)
With Shape1
.Name = neme + CStr(no)
.Line.Weight = 1
.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Fill.Visible = msoFalse
End With
ActiveSheet.Range(rng).Select
ErrorTrap:

End Sub