• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Klasörden Resim Çağırma Hk.

İki yöntem ile yapılabilir.

1- Tüm resimleri silersiniz. İlgili yerlere klasördeki resimleri yüklersiniz.
Bu şekilde sadece var olan resimler yüklenmiş olur.
2- İlk yükleme yaparken resimleri yüklerken resim isimlerini dosya isimleri ile aynı yaparsınız. Daha sonra resim isimleri klasörde aranır, yok ise excel den silinir.
 
Merhaba, arkadaşlar hücreye klasörden resim çağırma ile ilgili, özet tablomdaki E1 hücresindeki değere göre G1:H6 birleştirilmiş hücresine resim gelmesini istiyorum. Bu konuda aşağıdaki internet adresindeki kod bilgisi ve ekli dosya çok yardımcı oldu fakat bir türlü resimi ilgili dosyadaki gibi sabit olarak G1:H6 birleştirilmiş hücreye sabitlemeyi başaramadım. Kendi hazırladığım dosyada resim şu an mouse ı nereye tıklarsam oraya geliyor ve boyutlandırılmadan geliyor. Bu kodda nereyi ne şekilde değiştirmem lazım , destek olabilir misiniz.

http://www.yazilimmutfagi.com/11438/ms-office/excel/excelde-klasorden-dinamik-resim-cagirma-ekleme-ve-gosterme-ornek.aspx

Mevcut kod ;

'resmi oluşturuyoruz.
Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
'Resmi boyutlandırıyoruz
With Range("g1:h6" & i)
*****Resim.Top = .Top
*****Resim.Left = .Left
*****Resim.Height = .Height
*****Resim.Width = .Width
End With
 
İlgili linkdeki kodları kullanarak aşağıdaki şekilde yapabilirsiniz. Döngü kurmanıza gerek yok.
Kod: 
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, [E1]) 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("E" & 1) & ".jpg"
 
    'dosya yok ise hataya düsmemek için asagidaki kontrolü yapiyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("E" & 1) & ".jpg"
   Else
         ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
   End If
         
    'resmi olusturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandiriyoruz
     With Range("g1:h6")
     Resim.ShapeRange.LockAspectRatio = msoFalse
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
 
'Next i
Çikis:
End Sub
 
askm' Alıntı:
İlgili linkdeki kodları kullanarak aşağıdaki şekilde yapabilirsiniz. Döngü kurmanıza gerek yok.
Kod: 
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, [E1]) 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("E" & 1) & ".jpg"
 
    'dosya yok ise hataya düsmemek için asagidaki kontrolü yapiyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("E" & 1) & ".jpg"
   Else
         ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
   End If
         
    'resmi olusturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandiriyoruz
     With Range("g1:h6")
     Resim.ShapeRange.LockAspectRatio = msoFalse
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
 
'Next i
Çikis:
End Sub
Genişletmek için tıkla ...

Merhaba sayın "askm", öncelikle yardımlarınız için çok teşekkür ederim. Problem çözüldü. Konuyla ilgili bir soru daha sormak istiyorum. Normalde ilgili excel dosyasını deneme amaçlı resim ile aynı klasörde tutarak deneme yapıyordum. Bu şekilde sizinde katkılarınızla problem çözülmüştü. Fakat şimdi dosyayı firmanın ortak klasörlerine taşıdım ve resimler için de ek bir klasör oluşturdum ve koddaki kısayol alanına ilgili yolu yazdım ama bu sefer resimler gelmedi. Excel dosyasının kısayolunu ve resimlerin kısayolunu aşağıda paylaşıyorum, desteğinizi rica ederim. Bu durumda makrodaki dosya yolu kısımlarını nasıl düzenlemem lazım?

Not: Ortak kullanıma açık firma dosyalarına firmadayken de dahil olmak üzere wireless ağ bağlantısı üzerinden bağlanıyoruz. Belki hata sebebi bu olabilir diye not düşmek istedim.

Dosya kısayolu : \\xxxxx\depo\Planlama\Günlük_Planlama\2018\Mart
Resim kısayolu : \\xxxxx\depo\Planlama\Desen_resimler
 
Öncelikle kodun başına
Dim Resim_yolu
Resim_yolu : "\\xxxxx\depo\Planlama\Desen_resimler"
ekleyin sonra
ActiveWorkbook.Path gördüğünüz yerlere Resim_yolu yazarak deneyin.
 
Bu hayatımda makroyla ilk tanışmam olduğu için uğraştım ama yapamadım. Ekte ekran görüntüsünü gönderiyorum, teşekkür ederim.
 

Ekli dosyalar

  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    78.6 KB · Görüntüleme: 3
Son düzenleme:
Tamam çözdüm, askm çok teşekkür ederim, sizin sayenizde oldu.
 
Rica ederim. Kolay gelsin.
 
Merhabalar

Örnek dosya ektedir. kodda aşağıdaki gibidir.

"D" sütünundaki model kodlarına göre "AS" sütununa resim eklemek istiyorum. Problemi bulamadım. Yardımlarınız için teşekkürler




Private Sub Worksheet(ByVal Target As Range)

If Intersect(Target, [d:d]) 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 = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("d" & satır) & ".jpg"

Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & satır)
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With

Next satır

Çıkış:

End Sub
 

Ekli dosyalar

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d:d]) 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 = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("d" & satır) & ".jpg"

Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & satır)
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With

Next satır

Çıkış:

End Sub
 
askm' Alıntı:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d:d]) 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 = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("d" & satır) & ".jpg"

Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & satır)
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With

Next satır

Çıkış:

End Sub
Genişletmek için tıkla ...

Merhaba

Sizin kodu ekledim ama sadece 1. satıra getiriyor.

Bu raporu başka bir programdan excele atıyorum kodların yanına tırnak işareti atıyor

Bu yüzden AR sütununa göre arama yapsın dedim ama gene olmadı.

HÜcreye tam olarak resmide sığdırmıyor
 

Ekli dosyalar

Change olayı ile resim çağırıp döngü neden kullandığınızı anlamadım.Eğer döngü kullanacaksanız butona atamanız gerekir.
Normalde kodlar resim ekliyor ama eklene resimler tekrar döngü içerisinde siliniyordu.
Aşağıdaki şekilde deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [AR:AR]) Is Nothing Then Exit Sub
Dim Resim As Picture, Alan As Range
' hata kontrolü
On Error GoTo Çıkış

'resimleri Sil
Set Alan = Range("AS" & Target.Row)
 For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
Next
    
'ActiveSheet.DrawingObjects.Delete

'resim yolunun bulunması

Dim ResimYolu As Variant


'For satır = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("AR" & Target.Row) & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & Target.Row)
Resim.ShapeRange.LockAspectRatio = False
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
Resim.Left = .Left
End With

'Next satır

Çıkış:

End Sub
 
askm' Alıntı:
Change olayı ile resim çağırıp döngü neden kullandığınızı anlamadım.Eğer döngü kullanacaksanız butona atamanız gerekir.
Normalde kodlar resim ekliyor ama eklene resimler tekrar döngü içerisinde siliniyordu.
Aşağıdaki şekilde deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [AR:AR]) Is Nothing Then Exit Sub
Dim Resim As Picture, Alan As Range
' hata kontrolü
On Error GoTo Çıkış

'resimleri Sil
Set Alan = Range("AS" & Target.Row)
 For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
Next
    
'ActiveSheet.DrawingObjects.Delete

'resim yolunun bulunması

Dim ResimYolu As Variant


'For satır = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("AR" & Target.Row) & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & Target.Row)
Resim.ShapeRange.LockAspectRatio = False
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
Resim.Left = .Left
End With

'Next satır

Çıkış:

End Sub
Genişletmek için tıkla ...

Merhaba

Aşağıdaki linkten aldım bu kodu

https://www.youtube.com/watch?v=KZwcN8DhaT0

Şimdi resim geliyor ama yeni bir kod yazdığımda resim silinmiyor
 
Son düzenleme:
Aktif satırdaki AS sütunundaki resimleri siliyor sorun gözükmüyor.
 
askm' Alıntı:
Aktif satırdaki AS sütunundaki resimleri siliyor sorun gözükmüyor.
Genişletmek için tıkla ...

Şöyleki

Ben bu raporu excel atıp bu tabloya yapıştıracağım bu yüzden "D" sütunundaki kodlar değişecek

Şimdi manuel 5-6-7-8 yazdım "AR" sutünundaki resimler hata verdi.Yeni resimleri "AS" sütununa attı

Tablo ekteki gibi oldu
 

Ekli dosyalar

Bir önceki kodlar AR sütununa göre işlem yapıyordu. Yani resim adları AR sütununda idi. Şimdi D sütununa almışsınız. R sütununa herhangi bir müdahele yok kodların içerisinde. Ne resimlerini siliyor ne de resim ekliyor. Eklediğiniz resimdeki hatalar Daha önceden yüklediğiniz dosyada resimlerin olmadığını yani artık resimlerin var olan yerinde olmadığını bildiriyor.
 
askm' Alıntı:
Bir önceki kodlar AR sütununa göre işlem yapıyordu. Yani resim adları AR sütununda idi. Şimdi D sütununa almışsınız. R sütununa herhangi bir müdahele yok kodların içerisinde. Ne resimlerini siliyor ne de resim ekliyor. Eklediğiniz resimdeki hatalar Daha önceden yüklediğiniz dosyada resimlerin olmadığını yani artık resimlerin var olan yerinde olmadığını bildiriyor.
Genişletmek için tıkla ...

Sayın askm

İlginize çok teşekkürler

Kodu aşağıdaki şekilde düzelttim. AR sütununa artık resimler gelmiyor. Sadece "AS" sütununa geliyor

Sadece Raporu yapıştırdığım da "D" sütununda F2+Enter yapmam gerekiyor. Yoksa resimler gelmiyor.

Tekrar teşekkürler

Düzeltilmiş Kod


Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [D:D]) Is Nothing Then Exit Sub
Dim Resim As Picture, Alan As Range
' hata kontrolü
On Error GoTo Çıkış

'resimleri Sil
Set Alan = Range("AR" & Target.Row)
For Each Resim In ActiveSheet.Pictures
If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
Resim.Delete
End If
Next

'ActiveSheet.DrawingObjects.Delete

'resim yolunun bulunması

Dim ResimYolu As Variant


'For satır = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("D" & Target.Row) & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & Target.Row)
Resim.ShapeRange.LockAspectRatio = False
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
Resim.Left = .Left
End With

'Next satır

Çıkış:

End Sub
 
merhaba benzer bir sorun yaşıyorum hata kontrolünü değiştirmem gerekiyor aranan isinde resim yoksa hatayı yok sayıp sıradakine devam etmesini yada belirlediğim bir resmi koyup sıradakine devam etmesi istiyorum yardımcı olursanız çok sevinirim

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c:c]) 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 = 3 To 1103 Step 11

Resimyolu = ActiveWorkbook.Path & "\" & Range("c" & satır) & ".jpg"

'resim oluştur
Set Resim = ActiveSheet.Pictures.Insert(Resimyolu)

'Resimi Boyutlandır


With Range("c" & satır + 1)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With

Next satır

çıkış:
End Sub
 
askm' Alıntı:
Rica ederim. Kolay gelsin.
Genişletmek için tıkla ...

Merhaba, bana daha önce yardım ettiğiniz bu konuda sorum olacaktı.
Şimdi resim çağırdığım sayfaya adım ile makro kaydedip buton ataması yapmak istiyorum, aslında yapıyorum da ama filtrelerdeki değeri değiştirince buton kayboluyor. özelliklerden otomatik taşıma ve boyutlandırmayı kaldırdığım halde yine kayboluyor. Forumda bir arkadaş daha önceki destek verdiğiniz makro kodundaki bir satır sebebiyle butonun da silindiğini söyledi (ActiveSheet.DrawingObjects.Delete). Bahsettiği satır sanırım mevcut resimi silmek için kullanılan satır. Sizden ricam silme işlemini 9. satırdan itibaren başlamasını sağlayabiliyor muyuz ? Ben ilk 8 satıra makro butonları koyacağım. Resmi de N9:O28 arasına konumlandırdım. Destekleriniz için teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst