Buton Sabitleme- Yeniden getirme

[semih001]

selamlar;

çalışma Sayfası yenilendiğinde eklediğim buton kayboluyor. Sayfa yenilendiğinde makro atadığım buton kaybolmasın ya da yeniden gelsin istiyorum. Sayfadaki diğer makro resim getirme makrosu. Yardımcı olabilirseniz sevinirim.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ResimYolu As String
If Not Intersect(Target, [E3]) Is Nothing Then
DrawingObjects.Delete
ResimYolu = ActiveWorkbook.Path & "\" & Range("E3")

If Dir(ResimYolu & ".jpg") <> "" Then
ResimYolu = ResimYolu & ".jpg"
ElseIf Dir(ResimYolu & ".png") <> "" Then
ResimYolu = ResimYolu & ".png"
Else
MsgBox "'" & Range("E3") & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
Exit Sub
End If

Set resim = Pictures.Insert(ResimYolu)
With Range("H5:I14")
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With
End If
End Sub

 

[semih001]

Elimde bir de bu kod var ancak düzenleyemedim

Private Sub Worksheet_Change(ByVal Target As Range)
Dim btn As Button
For Each btn In Me.Buttons
btn.Delete
Next btn
Set btn = Me.Buttons.Add(Left:=100, Top:=50, Width:=100, Height:=30)
With btn
.Caption = "Yeni Buton"
.OnAction = " Butonun çalıştıracağı MakroAdı"
End With
End Sub

 

[Biolightant]

Merhaba,

resim.Width = .Width satırının altına aşşağıda ki satırı ekleyiniz.

resim.OnAction = "MakroIsmi"

 

[semih001]

Merhaba,

resim.Width = .Width satırının altına aşşağıda ki satırı ekleyiniz.

resim.OnAction = "MakroIsmi"

selamlar, denedim fakat sonuç alamadım. Buton yine kayboluyor.

 

[Biolightant]

E3 hücresin de bir değişiklik olduğun da
Excel kitabının kayıtlı olduğu dosya yolunda
E3 hücresi Değeri(Value) ile aynı Ad da jpg veya png dosyası var ise
Bu image dosyasını sayfanın H5:I14 hücrelerinin olduğu yeri kaplayacak şeklinde yerleştiriyor
Ve bu image tıklanınca istediğiniz makro çalışıyor (image button a dönüştü)

Bu butondan mı bahsediyorsunuz ?
isteginiz bu ise sizin kodlarınızda revizeye göre çalışıyor

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ResimYolu As String
If Not Intersect(Target, [E3]) Is Nothing Then
DrawingObjects.Delete
ResimYolu = ActiveWorkbook.Path & "\" & Range("E3")

If Dir(ResimYolu & ".jpg") <> "" Then
ResimYolu = ResimYolu & ".jpg"
ElseIf Dir(ResimYolu & ".png") <> "" Then
ResimYolu = ResimYolu & ".png"
Else
MsgBox "'" & Range("E3") & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
Exit Sub
End If

Set resim = Pictures.Insert(ResimYolu)
With Range("H5:I14")
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
resim.OnAction = "MakroIsmi" ' kendi makronuzun ismini yazacaksınız.
End With
End If
End Sub