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

[OKUROGLU3375]

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.

 

[OKUROGLU3375]

...

 

[halit3]

bu kodu bir dene

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]

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]

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ı

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

 

[OKUROGLU3375]

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.

 

[halit3]

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]

Halit bey herşey istediğim gibi çalışıyor. İlginize ve emeklerinize teşekkür ederim. Saygılar

 

[halit3]

5 nolu masajdaki kodu güncelledim

 

[OKUROGLU3375]

İlginize ve emeklerinize teşekkür ederim. Saygılar