Excel hücresine makro ile resim getirme

[manyakbiri]

Değerli üstatlar ve yardımsever üyeler ne zamandan beri faydalandığım ve müteşekkir kaldığım bu kıymetli forumda hepinize selamlar,

Excelde, bilgisayarın içindeki resimleri excel hücresinin içine tam sığacak şekilde getirtmek istiyorum.

Çalışacağım excelde yüzlerce satır olacak.

Resimlerin isimleri exceldeki her bir satırda yazıyor ve hepsinin windowstaki yeri aynı. Bir resmin adı 14567.jpg ise bir diğerkinin 677899.jpg gibi.

Bu gelen resimleri hücrenin içine tam sığacak şekilde gelsin istiyorum.

Bir resim üzerinden gitmek gerekirse, resmin windows'taki adresi bu diyelim.

Q:\Users\manyakbiri\Desktop\Sadece Bana Ait\Birtakım Resimler\14567.jpg

Bir alttaki satırın adresi şu olacak;

Q:\Users\manyakbiri\Desktop\Sadece Bana Ait\Birtakım Resimler\677899.jpg

Yapmak istediğim işin çok basit ekran görütünsü de burada. Bence bu iş yapılabilir. B2 hücresinden itibaren resimlerin taşmayacak şekilde tam olarak hücrenin içine gelmesini istiyorum.
Eğer yardımcı olursanız çok memnun olurum.



Cevaplarınızı bekleyeceğim.

 

[Haluk]

Ekli dosyayı indirip, Excel dosyasını açın. Sayfadaki butona tıklayın .....

https://drive.google.com/open?id=1sPkBfmRp0kCA7A2yh3QYFlALNHmI6lod

.

 

[manyakbiri]

Sayın Haluk,

Öncelikle çok teşekkür ederim. Söz ettiğim işlemin yapılabileceğini anlamış oldum.

Sizin yazdığınız makroda, resimlerin bulunduğu adresi nasıl değiştirmek gerekir?

Sub Test()
    ' Haluk - 15/06/2019
    ' sa4truss@gmail.com
    '
    Dim NoA As Long, i As Long
    Dim PicFile As String, PicTop As Integer, PicLeft As Integer, PicW As Integer, PicH As Integer
    NoA = Range("A" & Rows.Count).End(xlUp).Row
  
    For i = 2 To NoA
        PicFile = ThisWorkbook.Path & "\Resimler\" & Range("A" & i).Text & ".jpg"
        If Dir(PicFile) = Empty Then
            Range("B" & i) = "Resim bulunamadı..!"
            GoTo ResumeFor:
        End If
        PicTop = Range("B" & i).Top
        PicLeft = Range("B" & i).Left
        PicW = Range("B" & i).Width
        PicH = Range("B" & i).Height
        Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
ResumeFor:
    Next
End Sub

Bu koddaki \Resimler\ kısmını şununla değiştirdim \Q:\Users\manyakbiri\Desktop\Sadece Bana Ait\Birtakım Resimler\

olmadı.

Ne yapmak gerekir? Ben resimleri bu adresteki klasörden getirmesini istiyorum. Yardım edersen mutlu edersin.

 

[Haluk]

Kodda aşağıdaki satırın yerine;

PicFile = ThisWorkbook.Path & "\Resimler\" & Range("A" & i).Text & ".jpg"

resimlerin olduğu klasörün dosya yolunu yazabilirsiniz...

PicFile = "Q:\Users\manyakbiri\Desktop\Sadece Bana Ait\Birtakım Resimler\" & Range("A" & i).Text & ".jpg"

.

 

[manyakbiri]

Hocam sana tek diyeceğim; elin kolun dert görmesin.

Şu dünyada yardımlaşmaktan daha değerli bir iş yok.

Ben şimdi yüzlerce satırlık başka bir excel dosyasında bu makroyu kullanacağım (makro içerisinde bazı hücre adreslerini değiştirerek), problemle karşılaşırsam bu başlık altında gene seni bulacağımı ümit ediyorum.

Çok sağol, teşekkür ederim.

 

[manyakbiri]

Kodda aşağıdaki satırın yerine;

PicFile = ThisWorkbook.Path & "\Resimler\" & Range("A" & i).Text & ".jpg"

resimlerin olduğu klasörün dosya yolunu yazabilirsiniz...

PicFile = "Q:\Users\manyakbiri\Desktop\Sadece Bana Ait\Birtakım Resimler\" & Range("A" & i).Text & ".jpg"

.

Sayın Haluk, yeniden merhaba,

Sizin yazdığınız makroyu 500 küsür satırlık bir excelde kullandığımda resimleri 250. satıra kadar (tam 250 değil, hemen hemen yarısına kadar) getirdi, devamını boş bıraktı.

Son satıra kadar çalışması için ne yapmak gerek?

Yardımcı olursan çok sevinirim.

 

[Haluk]

Kodda bir sorun yok, "A" sütununda son satıra kadar çalıştırılmak üzere tasarlandı....

Sizin dosyanızda, "A" sütunundaki hücreler arasında boşluk olabilir veya başka bir sorun olabilir, bilemiyorum. Dosyanızı ekleyin, bakalım..... ya da e-posta ile gönderin.

.

 

[manyakbiri]

Run time error

Overflow

hatası alıyorum.

Bu spesifik bir hata sanırım.

 

[Haluk]

Hangi satırda ?

.

 

[Haluk]

Ben 500'den fazla satır için deneme yaptım, sorun olmadı.

Yazdığınız hata mesajını verecek bir durum yok kodlarda, kodları değiştirdiyseniz bir şeyleri muhtemelen yanlış yapıyorsunuz...... ya da dosyanızda veya resimlerde bir enterasanlık var, buradan göremiyorum.

.

 

[manyakbiri]

Merhaba,

Şu satırı sarıya boyuyor sistem;

PicTop = Range("E" & i).Top

Ayrıca başka bir şey daha eklemek isterim: Aynı dosyada makroyu yeniden çalıştırdım bu sefer son hücreye kadar resmi getirdi. Bu makro neye göre hata veriyor neye göre çalışıyor anlayamadım. Her daim çalışan bir makro gerekli.

 

[Haluk]

Makroda bir sorun yok ...... Her daim çalışır, ben şimdi tekrar denedim.

.

 

[manyakbiri]

Bence de kodlarda sorun yok, satır sayısının fazlalığı o hatayı almamıza sebep oluyor gibi.

 

[Haluk]

Hayır..... satır sayısının fazla olması ihtimaline karşılık NoA ve i değişkenleri Long olarak deklare edilmişti, sorununuz bundan kaynaklanmıyor.

Dosyanızda fazla sayıda biçimlendirme, hücre birleştirme vb görsellikler, satırlar arasında boşuk olup, olmaması, resimlerin tümünün uzantılarının kontrol edilmesi gibi durumları kontrol edin.

.

 

[Zeki Gürsoy]

Resimler büyük boyutta ise, (örneğin 10 MB) 500 resim o anda kullanılan belleği şişirebilir. Özelikle 32 bit Excel ise...

 

[manyakbiri]

Kodda bir sorun yok, "A" sütununda son satıra kadar çalıştırılmak üzere tasarlandı....

Sizin dosyanızda, "A" sütunundaki hücreler arasında boşluk olabilir veya başka bir sorun olabilir, bilemiyorum. Dosyanızı ekleyin, bakalım..... ya da e-posta ile gönderin.

.

Selamlar,

sa4truss@gmail.com adresinize mail attım. Bakarsanız sevinirim.

 

[halit3]

Zeki beyin dediği gibi bellek şişiyor olabilir bu durumda resimlerle ilgili 50 yada 100 tanede bir kodu bir kaç saniye bekletmek gerekebilir.

bu kod her elli resimde bir beş saniye kodu duraklatıyor.

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("00:00:05"))
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0
End If

 

[Haluk]

Mail ile gönderdiğiniz dosyada kod yok, örnek resim de yok ...... olmayan bir şey için de yorum yapamam.

.

 

[manyakbiri]

Yardım eden, etmek isteyen herkese çok teşekkürler.

Ofisteki bir arkadaşımız problemi başka bir kod yazarak çözdü tabii sizin destekleriniz olmadan olmazdı.

@Haluk size özel teşekkürlerimi ayrıca sunarım. Mail ile gönderdiğim dosyada, bu başlıkta paylaştığınız makroyu kendiniz yazarsınız diye düşündüm. Ben size makrolu halde göndersem zaten siz gene onu mecburen düzeltmek zorunda kalacaktınız çünkü resimlerin windows adresleri farklı. Bendeki 500 resmi size göndermem kolay olmazdı bundan ötürü kendi bilgisayarınızdaki resimleri excel dosyasına yazdığınız makro ile getirip kendiniz test etmenizi bekledim.

 

[gicimi]

Ekli dosyayı indirip, Excel dosyasını açın. Sayfadaki butona tıklayın .....

https://drive.google.com/open?id=1sPkBfmRp0kCA7A2yh3QYFlALNHmI6lod

.

Haluk Bey dosya silinmiş rica etsem tekrar güncelleyebilir misin.