الشكل يتبعك حيث ما كنت داخل الشيت

[الـعيدروس]

السلام عليكم

الاستاذ الحبيب ابو حنين حفظك الله

اعجبني هذا العمل جزاك الله كل خير

واحببت أن اضيف اضافة بسيطه وهذا بعد اذنك

أن الشكل ينشاء اتومتيك

هذه الأكواد في مودويل

Public Sh_A   As Shape

Sub Ali_Add()

Dim A

Dim B

Dim C

Set A = ThisWorkbook.VBProject

Set C = A.VBComponents.Item("My_C").CodeModule

C.AddFromString ("Sub Sh_Addres" & vbCrLf & "dim S$" & vbCrLf & "S = ""Ali_Sh"" " & vbCrLf & "Set Sh_A = ActiveSheet.Shapes(S)" & vbCrLf _

& "MsgBox ""  أنا الآن في الصف رقم : "" & Sh_A.TopLeftCell.Row & ""  العمود رقم  :  "" & activeCell.Column " & vbCrLf _

& " set Sh_A = nothing " & vbCrLf & "End Sub")

End Sub

Sub Ali_M()

Set V_A = ActiveWorkbook.VBProject

Set V_b = V_A.VBComponents.Add(vbext_ct_StdModule)

V_b.Name = "My_C"

End Sub

Sub Ali_Delet()

On Error Resume Next

Dim V_A

Dim V_b

Set V_A = ActiveWorkbook.VBProject

Set V_b = V_A.VBComponents("My_C")

ActiveWorkbook.VBProject.VBComponents.Remove V_b

End Sub

وهذا كودك وعليه تعديل بسيط " كود حدث الورقة "

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

With Target

With ActiveSheet

On Error Resume Next

  .Shapes("Ali_Sh").Delete

End With

Set Sh_A = ورقة1.Shapes.AddShape(msoShapeActionButtonend, .Left, .Top, .Width, .Height)

With Sh_A

  .TextFrame.HorizontalAlignment = xlHAlignCenter

  .TextFrame2.TextRange.Text = "أين موقعي"

  .Name = "Ali_Sh"

MsgBox " الصف :" & .TopLeftCell.Row & " العمود :" & Target.Column

Call Ali_Delet

Call Ali_M

Call Ali_Add

.OnAction = "Sh_Addres"

End With

End With

Cancel = True

End Sub

تحديد موقع_A.rar

[أبو حنــــين]

أخي الحبيب : أبو نصار ( حفظهما الله )

لقد أعطيت لمسة رائعة على الكود ، إنها ولا شك لمسة محترف حقا