Excelde Klasörden Dinamik Resim Çagirma Ekleme ve Gösterme Örnek

Bir excel sayfasinda girdiginiz bilgilere göre belirli bir klasör içindeki ilgili resmi alip excelin ilgili hücresine yazdirma ihtiyaciniz var ise bu makalemiz tam size göre.
Bu makalemizde örnek olarak bir ürün listesi yapacagiz, Bu ürün listesinde bulunan ürünler içinden baska bir sayfada liste olusturacagiz. Listeye girilen ürün bilgisine görede ilgili ürün resmini klasör içinden bulup getirecegiz.
Ilk olarak excel sayfamizi asagidaki gibi olusturulam. ilk sayfamizda ürünlerimizin idleri ve satis fiyatlarini yazalim, 

ikinci bir sayfa ekleyerek burada ilk sayfada ekledigimiz ürünlerin listesinin oldugu bir dropbox ekleyecegiz, bu dropboxdan ürünü seçtigimizde fiyat bilgisi ilk sayfadan otomatik olarak gelecek, bunu da düsey ara fonksiyonu ile yapacagiz. Bu kisimlari ayrintili olarak yazmiyorum, isteyen exceli asagidaki indirip inceleyebilir.


Ilk kisimlari yaptikdan sonra, resmi klasor içinden bulup yükleme kismi kaliyor. Bunuda macro yazarak yapacagiz. Bu islemi yapabilmek için ilk olarak ürün idlerinin bulundugu b kolonunda bir degisiklik olup olmadigini kontrol ediyoruz, bir degisiklik var ise, id bilgisini alip, excel sayfamizin bulundugu klasör içinde ayni isimli bir jpg dosyayi açip Resim kolonuna yüklüyoruz. Bu islem için asagidaki macroyu yazmamiz gerekiyor.

Public Function DosyaVarmi(dosyayolu As String) As Boolean
    On Error GoTo Çikis
    If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
    
Çikis:
    On Error GoTo 0
End Function

'worksheette bir degisiklik oldugunda bu kisim çalisiyor
Private Sub Worksheet_Change(ByVal Target As Range)

'degisiklik b sutunundami olmus diye kontrol et, degilse direk olarak fonksiyondan çik
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub

'herhangi bir hata olusursa Çikis labelina git
On Error GoTo Çikis:

' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete

Dim ResimDosyaYolu As String
Dim Resim As Object

'b deki 5 ile 12 arasindaki satirlari kontrol edip resim atamasi yapiyoruz, siz burayi isteginize göre artirabilirsiniz
For i = 5 To 12
    'aktif sayfanin path bilgisini alip, seçilen ürün idyi sonuna ekliyoruz ve dosyayi aliyoruz
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"

    'dosya yok ise hataya düsmemek için asagidaki kontrolü yapiyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
        End If
        
    'resmi olusturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandiriyoruz
     With Range("f" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With

Next i

Çikis:

End Sub
 

Sonuç olarak asagidaki gibi bir excel sayfamiz oluyor.

 

Excel dosyasi ve resimlerin oldugu klasörü asagidaki linkten indirebilirsiniz.

Örnek Dosya

7 thoughts on “Excelde Klasörden Dinamik Resim Çagirma Ekleme ve Gösterme Örnek

  1. merhaba,

    Sub deneme()
    Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [E:E]) Is Nothing Then Exit Sub

    ‘Hata Kontrolü

    On Error Resume Next

    ‘Resim Sil

    ActiveSheet.DrawingObjects.Delete

    ‘Resim Yolunun Bulunması

    Dim ResimYolu As Variant
    Dim Resim As Object

    For satır = 2 To 3000

    ResimYolu = “\\10.0.0.247\users\Planlama\Hms Raporlar\Status\Partpictures” & “\” & Range(“E” & satır) & “.PNG”

    ‘Resmi Oluştur
    Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

    ‘Resmi Boyutlandır

    With Range(“H” & satır)
    Resim.Top = .Top
    Resim.Left = .Left
    Resim.Height = 125
    Resim.Width = 70
    End With

    Next satır

    ActiveSheet.Shapes.SelectAll
    Selection.Placement = xlMoveAndSize
    Application.CommandBars(“Format Object”).Visible = False

    çıkış:
    End Sub

    şeklinde çelışıyor. ama resim bulamadığı zaman bir üst resmi kaydırıp alt satıra geçiriyor ve tüm dosya kayıyor. nasıl düzeltebilirim?

  2. Merhaba,

    A:M sütun ve 20.satır aralığına rakam girerek üzerine bu şekilde resim çağırabilirmiyiz.

  3. Arkadaşlar benim sorum su.
    Excrlde bilirkişi raporu hazırladığım bir program yazdım. Vba kullanmadan. Bu programda rapor sayfasında p7 hücresine hangi dosya numarasini girsem b82:k82 arasına uydu isimli klasörden p7 deki fotoğrafı getirsin. B281:k281 arasına ise bu programında içinde bulunduğu resimli ismindeki keşif fotoğrafını getirsin sağolun tesekkuler

  4. Private Sub Worksheet_CHANGE(ByVal Target As Range)

    If Intersect(Target, [G:G]) Is Nothing Then Exit Sub
    ‘hata kontrol

    On Error GoTo çıkış
    ‘resimleri Sil

    ActiveSheet.DrawingObjects.Delete
    ‘Resim Yolunun Bulunması

    Dim ResimYolu As Variant
    Dim Resim As Object

    For satır = 1 To 8

    ResimYolu = ActiveWorkbook.Path & “\Fotoğraflar\” & Range(“G” & satır) & “.jpg”

    ‘Resmi Oluştur
    Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

    ‘Resmi Boyutlandır

    With Range(“C” & satır)
    Resim.Top = .Top
    Resim.Left = .Left
    Resim.Height = .Height
    Resim.Width = .Width
    End With

    Next satır
    çıkış:
    End Sub
    Private Sub Worksheet_CHANGE(ByVal Target As Range)

    If Intersect(Target, [H:H]) Is Nothing Then Exit Sub
    ‘hata kontrol

    On Error GoTo çıkış
    ‘resimleri Sil

    ActiveSheet.DrawingObjects.Delete
    ‘Resim Yolunun Bulunması

    Dim ResimYolu As Variant
    Dim Resim As Object

    For satır = 1 To 8

    ResimYolu = ActiveWorkbook.Path & “\Fotoğraflar\” & Range(“H” & satır) & “.jpg”

    ‘Resmi Oluştur
    Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

    ‘Resmi Boyutlandır

    With Range(“F” & satır)
    Resim.Top = .Top
    Resim.Left = .Left
    Resim.Height = .Height
    Resim.Width = .Width
    End With

    Next satır
    çıkış:
    End Sub

Bir cevap yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir