Formül sonucuna göre hücreye resim eklemek/çağırmak

[emsey]

Üstad elinize emeğinize sağlık,
Tahsin hocanın verdiği kodları kendisi bildiği için hemen ek verdiği kodlar ile işim çözüldü ve tam istediğim gibi oldu.

Sizin kodlarıda arşivimde saklamak adına incelemek istedim. Aşağıdaki hata mesajını aldım.

Runtime erron "1004":
Picture sınıfının insert özelliği kullanılamıyor.

Merhaba
Boş bir module tıklayın ve bu kodları ekleyin deneyin.
Daha sonra butona atayabilirsiniz.
Dosya kapatıldığında resimlerin tamamı silinir.

Option Explicit
Sub resim_getir_1967()
'Konu       :   Hücrede Yazan Adrese Göre Resim Getir
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By  :   asi_kral_1967
Dim SAT As Long, AÇ As Variant, SİL As Variant
AÇ = ActiveCell.Address
Application.ScreenUpdating = False
For Each SİL In ActiveSheet.Shapes
If SİL.Type = 13 Then SİL.Delete
Next
For SAT = 6 To Cells(Rows.Count, "C").End(xlUp).Row
If Cells(SAT, "DE") <> Empty Then
Cells(SAT, "DE").Select
ActiveSheet.Pictures.Insert(Cells(SAT, "DE").Text).Select
Selection.Top = ActiveCell.Top
Selection.Left = ActiveCell.Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = ActiveCell.Height
Selection.ShapeRange.Width = ActiveCell.Width
End If: Next
Range(AÇ).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub
Sub auto_close()
Dim SİL As Variant
Application.ScreenUpdating = False
For Each SİL In ActiveSheet.Shapes
If SİL.Type = 13 Then SİL.Delete
Next
Application.ScreenUpdating = True
End Sub

Dosyanız Ekte.

 

[emsey]

öncekinde resim hücre boyutuna göre geliyordu, şimdi resim boyutunu bizim belirlememiz gerekiyor.
aşağıdaki kodlardan kendinize göre ayarlayınız.

Selection.ShapeRange.Height = 96 'yükseklik
Selection.ShapeRange.Width = 78 'genişlik
Selection.ShapeRange.IncrementLeft 3 'sağa kaydır
Selection.ShapeRange.IncrementTop 2.5 'aşağı kaydır

Ekli dosyayı inceleyiniz.

Tahsin hocam tam istediğim gibi oldu. Editleyerek boyutlandırmasınıda yaptım cuk diye oturdu. Çok teşekkür ediyorum. Size minnettarım.

 

[asi_kral]

Üstad elinize emeğinize sağlık,
Tahsin hocanın verdiği kodları kendisi bildiği için hemen ek verdiği kodlar ile işim çözüldü ve tam istediğim gibi oldu.

Sizin kodlarıda arşivimde saklamak adına incelemek istedim. Aşağıdaki hata mesajını aldım.

Runtime erron "1004":
Picture sınıfının insert özelliği kullanılamıyor.

Sorun çözüldüyse problem yok.
Hata alma sebebiniz DE sütununa girdiğiniz adresten kaynaklanıyor büyük bir ihtimalle ben oradaki yol bilgisini değiştirmiştim kendi pc'me göre

 

[emsey]

Sorun çözüldüyse problem yok.
Hata alma sebebiniz DE sütununa girdiğiniz adresten kaynaklanıyor büyük bir ihtimalle ben oradaki yok bilgisini değiştirmiştim kendi pc'me göre

Çok teşekkür ediyorum saygılar sunuyorum.

Şuan üzerinde çalışıyorum. Problem çıktıkça yazacağım.

 

[asi_kral]

Çok teşekkür ediyorum saygılar sunuyorum.

Şuan üzerinde çalışıyorum. Problem çıktıkça yazacağım.

Kolay Gelsin.

 

[emsey]

Tahsin hocam

aşağıdaki kodları çalıştırdığımda. rapor sayfasındaki fotoğraflar değil. Tüm excell sayfalarında ne kadar ikon, resim vs. varsa hepsini siliyor. Nerede düzeltme yapmam gerekecek.

Sub Resimlerisil()
Range("DE6E1000").ClearContents
Dim wks As Worksheet
For Each wks In Worksheets
wks.Pictures.Delete
Next wks
End Sub

 

[emsey]

Yardımcı olursanız sevinirim. Kodlar tüm excel sayfalarındaki resimleri siliyor. Bu sorunu aşamadım.

 

[tahsinanarat]

Modul1 deki kodları aşağıdaki kodlarla değiştiriniz

Sub resimlerigetir()
Belirli_Bir_Alandaki_Sekilleri_Sil
Application.ScreenUpdating = False
Dim Rng As Range
For Each Rng In Selection.SpecialCells(xlTextValues, 1)
If Rng.HasArray = True Then
Rng.ValueArray = Rng.Value
Else
Rng.Value = Rng.Value
End If
Next Rng
Application.ScreenUpdating = True
End Sub
Sub Belirli_Bir_Alandaki_Sekilleri_Sil()
Dim sekiL As Shape
For Each sekiL In ActiveSheet.Shapes
If Not Intersect(sekiL.TopLeftCell, Range("DE6E1000")) Is Nothing Then
sekiL.Delete
End If
Next
End Sub

 

[emsey]

Modul1 deki kodları aşağıdaki kodlarla değiştiriniz

Sub resimlerigetir()
Belirli_Bir_Alandaki_Sekilleri_Sil
Application.ScreenUpdating = False
Dim Rng As Range
For Each Rng In Selection.SpecialCells(xlTextValues, 1)
If Rng.HasArray = True Then
Rng.ValueArray = Rng.Value
Else
Rng.Value = Rng.Value
End If
Next Rng
Application.ScreenUpdating = True
End Sub
Sub Belirli_Bir_Alandaki_Sekilleri_Sil()
Dim sekiL As Shape
For Each sekiL In ActiveSheet.Shapes
If Not Intersect(sekiL.TopLeftCell, Range("DE6E1000")) Is Nothing Then
sekiL.Delete
End If
Next
End Sub

PC başında bekliyordum. Oldu hocam çok teşekkür ederim. Allah razı olsun

 

[tahsinanarat]

Güle güle kullan, birde süzülmüş verilerle ilgili bir sorunuz vardı, hallettiniz mi?

 

[emsey]

Güle güle kullan, birde süzülmüş verilerle ilgili bir sorunuz vardı, hallettiniz mi?

Şuan için hallettim. Bakalım başka sorunlar mutlaka çıkıyor. Çıktıkça inşallah paylaşıp çare ararım. Destekleriniz için çok teşekkür ediyorum.

 

[kaptan38]

ya ben anlamadım

 

[kaptan38]

Resimleri ekleme

Arkadaşlar önceki konuları okuyarak bende biraz uğraştım ancak yapamadım. Ekteki dosyadaki çalışmamda ilk sayfada veri seçimi yapıp dilekçe sayfasında standart dilekçe oluşturuyoruz. Buraya kadar eğer formülü ile işlem tamam. Ancak dilekçe sayfasında ilk sayfa dilekçe 2. Sayfa nufüs cüzdanı fotokopisi olacak şekilde veri sayfasına fotokopileri veri isimleri ile aynı olacak şekilde ekledim fakat 2. Sayfaya formüle göre nasıl ekleyebileceğimi çözemedim. Personel bilgi sistemi diye bi örnek vardı oradaki gibi yapmaya çalıştım. Olmadı. Yardımlarınızı bekliyorum. Iyi çalışmalar.

 

[kaptan38]

Yardım lütfen

arkadaşlar önceki konuları okuyarak bende biraz uğraştım ancak yapamadım. Ekteki dosyadaki çalışmamda ilk sayfada veri seçimi yapıp dilekçe sayfasında standart dilekçe oluşturuyoruz. Buraya kadar eğer formülü ile işlem tamam. Ancak dilekçe sayfasında ilk sayfa dilekçe 2. Sayfa nufüs cüzdanı fotokopisi olacak şekilde veri sayfasına fotokopileri veri isimleri ile aynı olacak şekilde ekledim fakat 2. Sayfaya formüle göre nasıl ekleyebileceğimi çözemedim. Personel bilgi sistemi diye bi örnek vardı oradaki gibi yapmaya çalıştım. Olmadı. Yardımlarınızı bekliyorum. ıyi çalışmalar.

dosya eklemeye çalışıyorum ancak olmuyor.

 

[hakansasal]

Selam arkadaşlar,
Öncelikle tam benimde aradığım bir şey fakat tc no ile resimlerin görüntüleneceği hücreleri nasıl değiştireceğimi bulamadım kodun içerisinde yardımcı olabilir iseniz sevinirim.

Saygılar sunar iyi çalışmalar dilerim.

 

[hakansasal]

Çözdüm gibi teşekkür ederim A:A yerine istediğin aralık 108 yerine de gitmek istediğin kadar sütün sayısı girildiğinde istenilen olabiliriyor

 

[HakanSENGUL]

Merhaba,
Dosyanız çok işe yaradı. Yalnız resim sil makrosu çalışmadı.
Butona tıkladığımda resimleri kaldırmıyor. Dolayısı ile bir sonraki açılışta resim üzerine bir tane daha yazmakta ve birkaç kapa/aç işleminden sonra pekçok aynı resim üst üste durmakta.

 

[piton7]

Biraz inceledim ama tam çözemedim.formülle resim eklemek mümkünmüdür.ufak bi paint çizimim var. istediğim direk şudur.
A37 hücresinde 1 yzıyorsa L37ye istediğim resmi koysun..A37 Hücresinde 2 yazıyorsa resmi koymasın.resim ve çizimde linkdedir.ancak bi butonla falan olmasını istemiyorum.Formül ile mümkünmüdür bu.


http://www.dosyayukleyin.com/do.php?id=5465]Kitap2.xlsx