• DİKKAT

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

VBA ile resim çağırma

  • Konbuyu başlatan Konbuyu başlatan nzmsmz
  • Başlangıç tarihi Başlangıç tarihi
N

nzmsmz

Katılım
25 Mayıs 2015
Mesajlar
94
Excel Vers. ve Dili
VBA
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 s2.dosya.tc
 
Dosyada bir sorun gözükmüyor.
 
ÖmerBey' Alıntı:
Dosyada bir sorun gözükmüyor.
Genişletmek için tıkla ...
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şş & ":D" & 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
 
muygun' Alıntı:
Merhaba;
Makro çözümlü Eki deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server6/2cux8x/nzmsmz-sayfadan_resim_getir.zip.html
Genişletmek için tıkla ...
ç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şş & ":D" & 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!
 
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şş & ":D" & 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.
 
muygun' Alıntı:
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şş & ":D" & 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.
Genişletmek için tıkla ...

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
 

Ekli dosyalar

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.
 
EmrExcel16' Alıntı:
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.
Genişletmek için tıkla ...
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
 
Sorunu İNdis ile çözebildim çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst