Klasör içinden Secili Hücreye Resimleri Cekme

[ean06]

merhaba,
Klasörüm iinde 3000 yakın resim var ve bunlar gün be gün çoğalıyor ..
Resim adı 20KB0001111 ürün kodları da aynı şekilde olmaktadır...
Sayfa 2 de A3 hüçresinde VERİ DOĞRULAMA Sayfa 1 den cekiyorum D3 hüçresine ise A3 den değiştirdikce D3 hüçresinde resimde tek tek değişmesini istiyorum...
aşağıda bir kod var ama bir türlü çalıştıramadım yardımlarınız için teşekkür ederim şimdiden herkese kolay gelsin.

Private Sub Worksheet_Change(ByVal Target As Range)

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

ActiveSheet.DrawingObjects.Delete

Dim ResimYolu As Variant
Dim resim As Object

ResimYolu = Dir(ActiveWorkbook.Path & "\" & ("D3") & ".jpg")

Set resim = ActiveSheet.Pictures.Insert(ActiveWorkbook.Path & "\" & ResimYolu)

With Range("D3")
resim.Top = .Top + 2
resim.Left = .Left + 2
resim.Height = .Height + 4
resim.Width = .Width - 4

End With


End Sub

 

[muygun]

Merhaba;
Sayfanın kod bölümüne;

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a3]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
yol = ActiveWorkbook.Path & "\"

Set Alan = Range("D3")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

If Dir(yol & "\" & Cells(3, "a").Value & ".jpg") <> "" Then
dosya = "\" & Cells(3, "a").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)

With Cells(3, "D")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With

With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
Application.ScreenUpdating = True
End Sub

Kodlarını yerleştirin ve A3 hücresinde resim adını değiştirerek deneyin.
İyi çalışmalar.

 

[ean06]

Merhaba,
İlginiz çok teşekkür ederim evet çalışıyor..Ama aşağıdaki iki sorun var ..
1 >D3 hücresine dışında bir alana geliyor resimler ( sağına doğru atıyor J K L M N sütunlara doğru atıyor )
2 >Fotoğraflar üst üst geliyor değiştikçe oradaki resimde kalkıp yerine diğeri gelmesi gerekiyor.
3 >Son olarak da birden fazla .jpg .jpeg uzantı var.
Çok teşekkür ederim ilginiz için tekrardan ve yardımcı olacak arkadaşlara....
hayırlı günler dilerim.

 

[owenefe]

Merhaba;
Sayfanın kod bölümüne;

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a3]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
yol = ActiveWorkbook.Path & "\"

Set Alan = Range("D3")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

If Dir(yol & "\" & Cells(3, "a").Value & ".jpg") <> "" Then
dosya = "\" & Cells(3, "a").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)

With Cells(3, "D")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With

With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
Application.ScreenUpdating = True
End Sub

Kodlarını yerleştirin ve A3 hücresinde resim adını değiştirerek deneyin.
İyi çalışmalar.

Bu kodu sizden ricam boyutunu şu şekilde revize edebilirmiyiz. fotoğrafın başlangıç noktası c sutunu bitişi g sutunu başlangıç 41.satır ile 50.satır gibi

 

[muygun]

Bu kodu sizden ricam boyutunu şu şekilde revize edebilirmiyiz. fotoğrafın başlangıç noktası c sutunu bitişi g sutunu başlangıç 41.satır ile 50.satır gibi

Merhaba;
Eki inceleyin ve deneyin.
İyi çalışmalar.

 

[muygun]

Merhaba,
İlginiz çok teşekkür ederim evet çalışıyor..Ama aşağıdaki iki sorun var ..
1 >D3 hücresine dışında bir alana geliyor resimler ( sağına doğru atıyor J K L M N sütunlara doğru atıyor )
2 >Fotoğraflar üst üst geliyor değiştikçe oradaki resimde kalkıp yerine diğeri gelmesi gerekiyor.
3 >Son olarak da birden fazla .jpg .jpeg uzantı var.
Çok teşekkür ederim ilginiz için tekrardan ve yardımcı olacak arkadaşlara....
hayırlı günler dilerim.

Neden sorun yaşadığınız anlayamadım ama ekteki uygulamayı deneyerek sorunlarınız gidermeye çalışın. (örnek dosyanız olmadığı için sorunu göremiyorum)
İyi çalışmalar.

Link:

İndir ean06 bulunduğu klasörden resim getir

Dosyayı indir ean06 bulunduğu klasörden resim getir

dosya.co

 

[owenefe]

Merhaba;
Eki inceleyin ve deneyin.
İyi çalışmalar.

hocam eline sağlık süper olmuş kendi dosyama uyarladım. Her sayfada seçmem gereken 4 fotoğraf var. Yani bu formülü 4lü hale nasıl getirebilirm. her sayfa 4 foto olucak ve her fotoğraf adı ve kendisi farklı tabiki. Kısacası attığınız formüle ilave nasıl yapabilirim

 

[muygun]

hocam eline sağlık süper olmuş kendi dosyama uyarladım. Her sayfada seçmem gereken 4 fotoğraf var. Yani bu formülü 4lü hale nasıl getirebilirm. her sayfa 4 foto olucak ve her fotoğraf adı ve kendisi farklı tabiki. Kısacası attığınız formüle ilave nasıl yapabilirim

Merhaba;
Sizin bir sorunuzu cevapladım.

Makro ile resim Çağırma

Arkadaşlar selam . Sitede epey bir bu konuda çalışma yapılmış çoğunu denedim kendime uyarlamaya çalıştım ama çok sağlıklı sonuçlar olmadı. Örnek Dosyayı ekledim. Her sayfada 4 adet anten fotoğrafım olacak ve her antenin numarası farklı. Her sayfa birbirinin simetriği zaten boyut şablon olarak...

www.excel.web.tr

(bir sayfaya 4 resim getirmekle ilgili) Onu kontrol edin. (sanırım aynı dosyaya uygulayacaktınız)