Resimlerin Sürekli Excelde Kalmasını sağlayacak Makro

[caneruysal]

Merhabalar,

Bir Excel Makrom bulunuyor, farklı bir konumdan ilgili ürünnumaraların resimlerini bulup ilgili satırlara getiriyor. Ancak bu excel her kapatıp açtığımda bu resimler tekrardan yükleniyor ve ben bunları özette görmek istediğimde 2-3 dakika beklemek durumunda kalıyorum. Bunun önüne nasıl geçebilirim ?

İlgili Kod Bloğu Aşağıdaki Gibidir;

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c:c]) Is Nothing Then Exit Sub
On Error GoTo tekrar
ActiveSheet.DrawingObjects.Delete

 Dim NoA As Long, i As Long
 Dim PicFile As String, PicTop As Long, PicLeft As Long, PicW As Long, PicH As Long


NoA = Range("C" & Rows.Count).End(xlUp).Row

For i = 2 To NoA
PicFile = "Dosyayolu" & "\" & Range("c" & i).Text & ".jpg"

If Dir(PicFile) = Empty Then
    Range("A" & i) = "Resim bulunamadı..!"
    GoTo ResumeFor:
End If


PicTop = Range("A" & i).Top
PicLeft = Range("A" & i).Left
PicW = Range("A" & i).Width
PicH = Range("A" & i).Height
Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
ResumeFor:
tekrar:
    Next
    
MsgBox "İşlem Adımları Tamamlanmıştır."
End Sub

 

[Cengiz Demir]

Makro sayfada değişiklik yapıldığında çalışacak şekilde ayarlanmış.. İlk açılışta o yüzden çalışıyor olabilir.
Eğer buna ihtiyacınız yoksa.
Kodları farklı bir makro içine alıp, düğme atarsanız, yenileme yapmak istediğinizde düğme ile yenilersiniz.
(Bu şekilde kullanacaksanız. Mevcut kodları silmeniz lazım.)

Örneğin..

Sub YeniMakro()

'Buraya kodlar eklenecek.

End Sub

 

[caneruysal]

Merhabalar, Aslında sorun düğme veya sayfadan kaynaklı değil. Düğmeye eklediğimde de exceli kapatıp açtığımda görseller ilk başta yüklenmemiş. Olarak geliyor. Şimdi aşağıya farklı bir kod bloğu atacağım. Bunu kullanınca görseller exceli açar açmaz geliyor fakat bu kod bloğu bende hata verirken başka bilgisayarda hata vermiyor. Acaba bu konuda yardımcı olabilecek var mı veya ilk kodu düzeltebilecek birileri.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c:c]) Is Nothing Then Exit Sub
On Error GoTo tekrar
ActiveSheet.DrawingObjects.Delete
Dim ResimYolu As String
Dim resim As Object
For satır = 2 To 5000


ResimYolu = "Dosyakonumu" & "\" & Range("c" & satır).Value & ".jpg"
If Dir(ResimYolu) = "" Then GoTo tekrar Else


    Set resim = ActiveSheet.Pictures.Insert(ResimYolu)


With Range("b" & satır)
resim.Top = .Top
resim.Left = .Left
resim.Height = ActiveCell.Height
resim.Width = ActiveCell.Width
resim.Select
Selection.Copy
Range("a" & satır).Select
ActiveSheet.Pictures.Paste.Select
Selection.Top = ActiveCell.Top
Selection.Left = ActiveCell.Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = ActiveCell.Height
Selection.ShapeRange.Width = ActiveCell.Width
resim.Delete

End With

tekrar:
Next satır


Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation
End Sub

Aldığım Hata Run-Time Error
Pictures sınıfının Paste özelliği kullanılamıyor.

Hatasıdır.