resim getirme

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
aşağıdaki makro ile 4000 personelin resimlerini çalışma sayfama 4 dk da getirtiyorum acaba bu makro revize edilerek süre dahada kısaltılabilirmi. Yardımlarınız için şimdiden teşekkürler
Sub resim_71()
Son = 3
ReDim uzanti(Son)
uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"

With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationAutomatic
End With

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
Sheets("KONTROL").Range("a8").Select

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
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Guncel
 
P

PLİNT

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Aşağıdaki gibi deneyiniz, faydası olacaktır
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Klasor = "C:\FOTO\"
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
Else
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
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
Merhaba
Aşağıdaki gibi deneyiniz, faydası olacaktır
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Klasor = "C:\FOTO\"
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
Else
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
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
Genişletmek için tıkla ...
bu satırda hata verdi sayın plint hocam

ActiveSheet.Pictures.Insert(Klasor & "d.jpg").Select
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
Merhaba
Aşağıdaki gibi deneyiniz, faydası olacaktır
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Klasor = "C:\FOTO\"
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
Else
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
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
Genişletmek için tıkla ...
pictures sınıfının insert özelliği anımıyor hatası veriyor
 
P

PLİNT

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Kodlarınız; "else" satırından önce;
"Foto" adlı klasörü hücredeki ismin fotoğrafı varmı diye kontrol ediyor varsa getiriyor, eğer yoksa "d.jpg" diye bir resmi getiriyor

ek teki örnek dosya gibi resmi olamayanın karşısına siyah resim gelecektir
https://www.dosyaupload.com/bawr (Denerken "foto" klasörü "xlsm" dosyasının yanında olsun)

Kodların amacı örnekteki gibi fotoğrafı bulamadığı zaman boş bir resim eklemekmiş. Ben sizdede "d.jpg" dosyasının olduğunu varsaymıştım.
Ayrıca ismi var da resim gelmiyorsa hücredeki isimle resmin adı uyuşmuyordur (ismin sonunda veya başında boşluk varsa bile getirmez)
Öyle bir dosya (fotolarda "d.jpg") yok ise kodlardan; aşağıdaki gibi o bölümü silerek kullanabilirsiniz
(fotoğrafı olmayan ismin karşısı boş kalacaktır)
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Klasor = ThisWorkbook.Path & "\FOTO\"
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Trim(Cells(i, 2).Value)
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
End If
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
 
Son düzenleme:
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
Merhaba
Kodlarınız; "else" satırından önce;
"Foto" adlı klasörü hücredeki ismin fotoğrafı varmı diye kontrol ediyor varsa getiriyor eğer yoksa "d.jpg" diye bir resmi getiriyor

ek teki örnek dosya gibi resmi olamayanın karşısına siyah resim gelecektir
https://www.dosyaupload.com/bawr (Denerken "foto" klasörü "xlsm" dosyasının yanında olsun)

Kodların amacı örnekteki gibi fotoğrafı bulamadığı zaman boş bir resim eklemekmiş. Ben sizdede "d.jpg" dosyasının olduğunu varsaymıştım.
Ayrıca ismi var da resim gelmiyorsa hücredeki isimle resmin adı uyuşmuyordur (ismin sonunda veya başında boşluk varsa bile getirmez)
Öyle bir dosya (fotolarda "d.jpg") yok ise kodlardan; aşağıdaki gibi o bölümü silerek kullanabilirsiniz
(fotoğrafı olmayan ismin karşısı boş kalacaktır)
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Klasor = ThisWorkbook.Path & "\FOTO\"
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Trim(Cells(i, 2).Value)
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
End If
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
Genişletmek için tıkla ...
Sayın plint hocam Benim getirdigim fotolar TC kimlik numarasına göre isimlendirilmiş
 
P

PLİNT

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
"B" sütununda da "tc" nolar varsa farketmezki
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
"B" sütununda da "tc" nolar varsa farketmezki
Genişletmek için tıkla ...
Evet b sütununda TC kimlik nolar var ben şimdi sizin yazmış olduğunuz makroya göre çalışma kitabımı fotoların bulunduğu klasörün icindemi calistiracagim orasını tam anlayamadım
 
P

PLİNT

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Hayır benim gönderdiğim örnek için demiştim
Aşağıda düzelttim
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
',,,,,,,
Klasor = "C:\FOTO\"
',,,,,,,,,,,,
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Trim(Cells(i, 2).Value)
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
End If
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
Hayır benim gönderdiğim örnek için demiştim
Aşağıda düzelttim
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
',,,,,,,
Klasor = "C:\FOTO\"
',,,,,,,,,,,,
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Trim(Cells(i, 2).Value)
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
End If
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
Genişletmek için tıkla ...
Deneyip size dönüş yapacağım sayın plint hocam yardımlarınız için çok teşekkür ederim
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
Hayır benim gönderdiğim örnek için demiştim
Aşağıda düzelttim
Kod: 
Sub resim_71()
With Application
.DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
',,,,,,,
Klasor = "C:\FOTO\"
',,,,,,,,,,,,
For i = 8 To Cells(Rows.Count, "B").End(3).Row
isim = Trim(Cells(i, 2).Value)
isim = Dir(Klasor & isim & ".*")
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim) = True Then
ActiveSheet.Pictures.Insert(Klasor & isim).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
Sheets("KONTROL").Range("a8").Select
End If
Next
With Application
.DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
Genişletmek için tıkla ...
Sayın plint bendeki makro ile hemen hemen aynı sürede getirdi sanırım bundan daha kısa sürede gelmesi mümkün gözükmüyor
 
P

PLİNT

Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Hepsinin birden gelmesi şart değilse;
Mesela "B10" hücresine tıkladığınız zaman o resmin gelmesi sağlanabilir
veya ""b" sütununda belirli hücreler seçilerek seçilen hücrelere göre
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
PLİNT' Alıntı:
Hepsinin birden gelmesi şart değilse;
Mesela "B10" hücresine tıkladığınız zaman o resmin gelmesi sağlanabilir
veya ""b" sütununda belirli hücreler seçilerek seçilen hücrelere göre
Genişletmek için tıkla ...
plint hocam listeler halinde toplu olarak resimli verilere ihtiyaç olduğu için tek tek getirmek maalesef işime yaramıyor galiba ihtiyaç halinde 4-5 dk beklemeye devam sanırım yardımlarınız için tekrardan çok teşekkür ederim. 4000 adet personel fotografını 4-5 dk da getirmek makul bir süre sanırım. Daha aşağısı yok gibi
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst