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.
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?
merhaba,
resim dosyada yoksa bir alt satıra nasıl geçirebilirim?
tamam hallettim onuda
Merhaba,
A:M sütun ve 20.satır aralığına rakam girerek üzerine bu şekilde resim çağırabilirmiyiz.
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
Спасибо за информацию!!!!!
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