Ana Sayfa » MS Office » Excel » Excelde Klasörden Dinamik Resim Çagirma Ekleme ve Gösterme Örnek

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

Yazar Hakkında

Yazilim Mutfagi

Makale Sayısı : 27

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

15 yorum
yorumekle yorumekle Toplam 1 Yorum Yapılmış. Sizde yorum yazmak ve soru sormak için bu linki takip edin. -Forum sayfasına yönlendirileceksiniz-

Yorumlar

  • avatar

    ýlharef

    Merhaba,

    A?a?ydaki kodlary ayny ?ekilde uyguladym vede çaly?ty fakat resimlerin doyutlary ayny
    olmady?yndan bazy resimler hücrelerin dy?yna ta?yyor veya resim küçük geliyor tam olarak
    hücreye sy?dyrabilmek mümkünmü yardymcy olursanyz sevinirim. ?imdiden te?ekkürler ederim







    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

    Cevapla Alıntı Yaparak Cevapla