Resim Getirme

[metin_0606]

Herkese iyi hafta sonları öncelikle. Çalışma Sayfamda A sütununda 5000 satırlık TC kimlik numaraları yazılı. Bu TC kimlik numaralarının karşılığına hücre genişliğine göre B1 sütunundan başlayarak C:\FOTO adresindeki klasörün içinde bulunan yine TC Kimlik numaralı 5000 adet fotografı kısa zamanlı makro ile getirtmek istiyorum. Bu konuda yardımcı olacak üstatlarıma şimdiden teşekkür ediyorum saygılar

 

[Merhum İdris SERDAR]

.

Buradaki dosyaları inceleyin.

http://www.excelgurusu.com/category/re/

.

 

[ByChilavert]

.

Buradaki dosyaları inceleyin.

http://www.excelgurusu.com/category/re/

.

Merhaba İdris Hocam

Aşağıda belirttiğim konuda sağolsun muygun resim getirme olayını halletti. sayfalara resimi otomatik nasıl sığdırabilirım onu bir türlü çözemedim. Yardımcı olabilir misiniz.
https://www.excel.web.tr/threads/kosula-bagli-resim-getirme.182784/#post-1007829

 

[metin_0606]

Herkese iyi hafta sonları öncelikle. Çalışma Sayfamda A sütununda 5000 satırlık TC kimlik numaraları yazılı. Bu TC kimlik numaralarının karşılığına hücre genişliğine göre B1 sütunundan başlayarak C:\FOTO adresindeki klasörün içinde bulunan yine TC Kimlik numaralı 5000 adet fotografı kısa zamanlı makro ile getirtmek istiyorum. Bu konuda yardımcı olacak üstatlarıma şimdiden teşekkür ediyorum saygılar

Sub resim_71()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
son = 3
ReDim uzanti(son)
uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"
Klasor = "C:\FOTO\"

For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
deg = 0
For j = 1 To son

If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim & uzanti(j)) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim & uzanti(j)).Select

Selection.Top = Cells(i, 10).Top + 2
Selection.Left = Cells(i, 10).Left + 2
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Cells(i, 10).Height - 4
Selection.ShapeRange.Width = Cells(i, 10).Width - 4
deg = 1

Exit For
End If
Next

If deg = 0 Then
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & "d.jpg") = True Then
ActiveSheet.Pictures.Insert(Klasor & "d.jpg").Select
Selection.Top = Cells(i, 10).Top + 2
Selection.Left = Cells(i, 10).Left + 2
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Cells(i, 10).Height - 4
Selection.ShapeRange.Width = Cells(i, 10).Width - 4
End If
End If

Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Bu Kodları burada bularak kendime göre revize ederek klasörden sayfama aynı anda 4500 civarı resim getirtiyorum. Ancak kodlar yavaş çalışıyor. Güncelleme yapılarak hızlandırmak mümkün mü acaba saygılar

 

[metin_0606]

güncel