VBA ile resim çağırma

[nzmsmz]

Merhaba

Ekte eklediğim test örneğine göre Resimleri "resim"sayfasından sicile göre nasıl çağırabilirim, 3 gündür uğraşıyorum. Birşeyi eksik yapıyorum ama neyi çözemedim. Farklı örnek dosyaları inceledim VBA ları kendim uyarladım ama istediğim resmi çekmiyor.

resimtest_.xlsm dosyasını indir - download

resimtest_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[muygun]

Merhaba;
Makro çözümlü Eki deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server6/2cux8x/nzmsmz-sayfadan_resim_getir.zip.html

 

[nzmsmz]

Merhaba;
Makro çözümlü Eki deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server6/2cux8x/nzmsmz-sayfadan_resim_getir.zip.html

Çok teşekkür ederim ancak dosya açılmıyor. Sizde açılıyormu

 

[ÖmerBey]

Dosyada bir sorun gözükmüyor.

 

[nzmsmz]

Dosyada bir sorun gözükmüyor.

Trojen uyarısına takılmş şu an açabildim dosyayı,

yalnız burada getir butonuna basmaya gerek duymadan B2 hücresindeki değer değiştiğinde otomatik gelse onun için nereyi revize etmek gerek

Sub getir()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("resimdata")
Set s2 = ThisWorkbook.Worksheets("Sayfa1")

Set Alan = Range("r1:t12")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
If s2.Cells(2, 2) <> "" Then
For i = 2 To s1.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) = s2.Cells(2, 2) Then
başş = i
bitt = i + 10
Sheets("resimdata").Select
Range("B" & başş & "" & bitt).Select
Selection.Copy
Sheets("Sayfa1").Select
Range("R2:T12").Select
ActiveSheet.Paste
Range("B2").Select
Application.CutCopyMode = False
Sheets("Sayfa1").Select
End If
Next i
End If
End Sub

 

[nzmsmz]

Merhaba;
Makro çözümlü Eki deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server6/2cux8x/nzmsmz-sayfadan_resim_getir.zip.html

çok teşekkür ederim yalnız burada getir butonuna basmaya gerek duymadan B2 hücresindeki değer değiştiğinde otomatik gelse onun için nereyi revize etmek gerek

Sub getir()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("resimdata")
Set s2 = ThisWorkbook.Worksheets("Sayfa1")

Set Alan = Range("r1:t12")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
If s2.Cells(2, 2) <> "" Then
For i = 2 To s1.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) = s2.Cells(2, 2) Then
başş = i
bitt = i + 10
Sheets("resimdata").Select
Range("B" & başş & "" & bitt).Select
Selection.Copy
Sheets("Sayfa1").Select
Range("R2:T12").Select
ActiveSheet.Paste
Range("B2").Select
Application.CutCopyMode = False
Sheets("Sayfa1").Select
End If
Next i
End If
End Sub






Alıntı Cevapla

Şikayet Et!

 

[muygun]

Merhaba;
Sayfadaki butonu silin.
Modülü silin.
Sayfa1 sayfasının kod bölümüne;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("resimdata")
Set s2 = ThisWorkbook.Worksheets("Sayfa1")
sat = Target.Row
süt = Target.Column

If sat = 2 And süt = 2 Then
Set Alan = s2.Range("r1:t12")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
If s2.Cells(2, 2) <> "" Then
For i = 2 To s1.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) = s2.Cells(2, 2) Then
başş = i
bitt = i + 10
Sheets("resimdata").Select
s1.Range("B" & başş & "" & bitt).Select
Selection.Copy
Sheets("Sayfa1").Select
s2.Range("R2:T12").Select
ActiveSheet.Paste
s2.Range("B2").Select
Application.CutCopyMode = False
Sheets("Sayfa1").Select
End If
Next i
End If
End If
End Sub

Kodlarını ekleyip deneyin.
İyi çalışmalar.

 

[nzmsmz]

Merhaba;
Sayfadaki butonu silin.
Modülü silin.
Sayfa1 sayfasının kod bölümüne;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("resimdata")
Set s2 = ThisWorkbook.Worksheets("Sayfa1")
sat = Target.Row
süt = Target.Column

If sat = 2 And süt = 2 Then
Set Alan = s2.Range("r1:t12")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
If s2.Cells(2, 2) <> "" Then
For i = 2 To s1.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) = s2.Cells(2, 2) Then
başş = i
bitt = i + 10
Sheets("resimdata").Select
s1.Range("B" & başş & "" & bitt).Select
Selection.Copy
Sheets("Sayfa1").Select
s2.Range("R2:T12").Select
ActiveSheet.Paste
s2.Range("B2").Select
Application.CutCopyMode = False
Sheets("Sayfa1").Select
End If
Next i
End If
End If
End Sub

Kodlarını ekleyip deneyin.
İyi çalışmalar.

Merhaba, yaptım fakat daha değişik bir hal aldı. Reismleri B2 deki alana atıyor ve sırayla kendi gitmeye başlıyor.

benim amacım B2 de örneğin sicil kodu var. O sicil kodunu değiştirdiğimde resminin de değişmesi.

Şu an kendi değiştiriyor Sicil ve resmi

 

[muygun]

Merhaba;
Ben öyle bir sorun göremedim.
Uygulama dosyasını inceleyin.
(Hala sonuç alamıyorsanız butonlu uygulamayla devam edin. Yada farklı bir çözüm gelmesini bekleyin.)
İyi çalışmalar.

Link:
https://s5.dosya.tc/server6/qikssg/nzmsmz-sayfadan_resim_getir-1.zip.html

 

[EmrExcel16]

Merhaba , @muygun üstadın verdiği kodlarda sıkıntı gözükmüyor , siz birde başlıkdaki Worksheet_SelectionChange bu kısmını bu şekilde Worksheet_Change değiştirerek deneyin.

 

[nzmsmz]

Merhaba , @muygun üstadın verdiği kodlarda sıkıntı gözükmüyor , siz birde başlıkdaki Worksheet_SelectionChange bu kısmını bu şekilde Worksheet_Change değiştirerek deneyin.

Tam olarak istediğim buydu teşekkür ederim

 

[nzmsmz]

Merhaba , @muygun üstadın verdiği kodlarda sıkıntı gözükmüyor , siz birde başlıkdaki Worksheet_SelectionChange bu kısmını bu şekilde Worksheet_Change değiştirerek deneyin.

Son bir soru daha. Sicil olan alan düşey ara formulle geliyor. Fakat o hücreyi seçip entere basmadıgım sürece resmi güncellemiyor. Bu neden olabilir

 

[nzmsmz]

Sorunu İNdis ile çözebildim çok teşekkür ederim