Sağdan sola doğru klasörden resim çağırma

OKUROGLU3375

Altın Üye
Katılım
29 Eylül 2017
Mesajlar
110
Excel Vers. ve Dili
professional_plus_2016 Türkçe
Selamlar;
Excel VBA ile ;
B5 hücresindeki isme göre B1 hücresine resim çağırmak ( Örnek b1-b4 satırları birleştirilmiştir.)
C5 hücresindeki isme göre C1 hücresine resim çağırmak ( Örnek b1-b4 satırları birleştirilmiştir.)
İncelediğim kadarıyla konular hep satır bazında aşağıya doğru resim yerleştirme konuları var. Yani soldan sağa yerleştirme yapmak için yardımlarınızı rica ediyorum. Bir klasörde çalışma dosyası ve resimler aynı klasörde bulunmaktadır.
- Hücrede isim yazıyorsa resim gelsin yoksa boş kalsın.... Yardımlarınız için teşekkür eder, iyi çalışmalar dilerim.
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
bu kodu bir dene

Rich (BB code):
Sub Listele()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
kaynak = Klasor.SELF.Path
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
If Right(kaynak, 1) <> "\" Then kaynak = kaynak & "\"

eskizom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100

For r = 2 To Worksheets(ActiveSheet.Name).Cells(5, Columns.Count).End(xlToLeft).Column

isim = Cells(5, r).Value & ".jpg"

Set Adres = Range(Cells(1, r), Cells(4, r))
If Cells(5, r).Value <> "" Then

If CreateObject("Scripting.FileSystemObject").FileExists(kaynak & isim) = True Then
Cells(1, r).Select
ActiveSheet.Pictures.Insert(kaynak & isim).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
Selection.ShapeRange.Name = Cells(5, r).Value

End If

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

End If

Next

ActiveWindow.Zoom = eskizom
Range("a1").Select
'MsgBox "işlem tamam"
CreateObject("WScript.Shell").Popup "işlem tamam", 1, " UYARI!", vbOKOnly + vbInformation
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 

OKUROGLU3375

Altın Üye
Katılım
29 Eylül 2017
Mesajlar
110
Excel Vers. ve Dili
professional_plus_2016 Türkçe
Selamlar; İlginize teşekkür ederim.
1- İlgili hücrelere isim yazdığım an resimlerin gelmesi mümkün mü? (Yani hücreye isim yazıp ENTER dediğim an gelebilir mi?) Her defasında klasör seçmek zorunda kalıyorum. Bir defa yol adresi yazsam ve her zaman oradan alsa olabilir mi?
2- Resimler ve Çalışma dosyası yolu C:\.......\PERSONEL TAKİP PROGRAMI

Yardımlarınıza teşekkür ederim.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kodu sayfanın kod bölümüne yapıştır
5. satıra işlem yapınca kod çalışacaktır.
not: kodun çalışması için dosyanın yanında Resimler klasörü olmalı ve resimlerde bu klasörün içinde olmalı

Rich (BB code):
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target.Rows, [5:5]) Is Nothing Then Exit Sub

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If s1.Cells(5, Target.Column).Value = "" Then Exit Sub

klasor = ThisWorkbook.Path & "\Resimler\"
isim = s1.Cells(5, Target.Column).Value & ".jpg"

If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim) = True Then
eskizom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100

Set Adres = Range(s1.Cells(1, Target.Column), s1.Cells(4, Target.Column))

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Set yer1 = s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column)
Set yer2 = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
yer = yer1.Address & ":" & yer2.Address

If yer = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

s1.Cells(1, Target.Column).Select
s1.Pictures.Insert(klasor & isim).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
Selection.ShapeRange.Name = Cells(5, Target.Column).Value


ActiveWindow.Zoom = eskizom
s1.Cells(5, Target.Column).Select
MsgBox "işlem tamam"
Else
MsgBox "resim yok"
End If

End Sub
 
Son düzenleme:

OKUROGLU3375

Altın Üye
Katılım
29 Eylül 2017
Mesajlar
110
Excel Vers. ve Dili
professional_plus_2016 Türkçe
Selamlar; Teşekkürler,
Kodları uygulama yaptığımda işlem tamam diyor ama resimler gelmiyor. Dosya ve resimler klasörünü sıkıştırarak ekledim.
İncelemenizi rica eder, iyi çalışmalar, iyi günler dilerim.
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
resimler klasörünün adı böyle olacak küçük büyük harf duyarlı olacak

(Resimler)

mehmet okur resmide yok klasörde
 

OKUROGLU3375

Altın Üye
Katılım
29 Eylül 2017
Mesajlar
110
Excel Vers. ve Dili
professional_plus_2016 Türkçe
Halit bey herşey istediğim gibi çalışıyor. İlginize ve emeklerinize teşekkür ederim. Saygılar
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
5 nolu masajdaki kodu güncelledim
 

OKUROGLU3375

Altın Üye
Katılım
29 Eylül 2017
Mesajlar
110
Excel Vers. ve Dili
professional_plus_2016 Türkçe
İlginize ve emeklerinize teşekkür ederim. Saygılar
 
Üst