Hücre adı içeriyorsa resim getir

[bebar]

Merhaba,

Hücre ile eşleşen durumlarda sayfama resim getiren aşağıdaki gibi kodum var ama hücre değeri ile resim adı aynı olması gerekiyor.
İstediğim resmin adı hücre değerini içeriyorsa resim getirmesi
örnek;
hücre değeri: 140255
resim adı :140255 tkm

gibi durumlarda resim gelmesini istiyorum.

binlerce resim olduğu klasörden çalışıyorum. yardımcı olursanız çok memunun olurum.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim s1 As Worksheet
Dim s2 As Worksheet
Set s1 = Sheets("Şablon")
Set s2 = Sheets("Resim")
x = s1.Cells(Rows.Count, 2).End(xlUp).Row
s1.Range("a6:a" & x).Select
Selection.ClearContents
s1.Range("a2").Select
    If Intersect(Target, Range("a6:a" & x)) Is Nothing Then Exit Sub
    Cancel = True
    Target.Font.Name = "Wingdings"
    Target = IIf(Target = "ü", "", "ü")
    s1.Cells(2, 3).ClearContents
    s1.Cells(2, 3) = Left(Cells(Target.Row, 2), 5)
    s1.Cells(2, 4) = Cells(Target.Row, 3)
    s1.Cells(2, 5) = Cells(Target.Row, 5)
    s2.Select
    sat1 = 2
    sat2 = 55
    sut1 = "a"
    sut2 = "k"


        Set Adres = s2.Range(s2.Cells(sat1, sut1), s2.Cells(sat2, sut2))
        Set Adres2 = s2.Cells(sat2, sut2)
            Dim yer
            Dim Picture As Object
           
    For Each Picture In ActiveSheet.Shapes
    If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
        Picture.Delete
    End If
    Next Picture

            son = 6
            ReDim uzanti(son)
                uzanti(1) = ".jpg"
                uzanti(2) = ".JPG"
                uzanti(3) = ".bmp"
                uzanti(4) = ".BMP"
                uzanti(5) = ".gif"
                uzanti(6) = ".GİF"

                klasor = "D:\Data\URUN_YONETIMI\Siparisler ve Üretim Kartelaları\DIŞ GİYİM\"

                isim = s1.Cells(2, "c").Value
           
            For j = 1 To son
                Dosya = klasor & isim & uzanti(j)
                    If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & uzanti(j)) = True Then
                        ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Adres.Left + 2, Adres.Top + 2, Adres.Width - 4, Adres.Height - 4
                        ActiveSheet.Cells(2, "c").Select

                        Exit For
                   
                    End If
            Next

End Sub

 

[bebar]

Yardımcı olabilecek bir arkadaş yok mudur?
yada istediğim mümkün mü?

 

[Kasniç]

Merhaba, Fikir olarak paylaşıyorum. Acaba klasor & isim & "*" & uzanti(j) gibi deneseniz.

 

[bebar]

maalsef kardeşim;
olursa - klasor & *isim* & uzanti(j) gibi olmalı oda mümkün değil

 

[Korhan Ayhan]

Merhaba,

Bu satırı ;

If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & uzanti(j)) = True Then

Aşağıdaki satır ile değiştirip deneyiniz.

If Dir(klasor & "*" & isim & "*" & uzanti(j)) <> "" Then

 

[bebar]

kusura bakmayın geç dönüş yaptım malum depremden sonra şirket tatile girdi şimdi deneyebildim
fakat " type mismatch" hatası verdi.

 

[Korhan Ayhan]

Geçmiş olsun. Allah C.C. daha kötülerinden korusun.

Ben küçük bir hata yapmışım. Revize ettim. Tekrar deneyiniz.

 

[bebar]

hocam kod yok

 

[Korhan Ayhan]

Önceki mesajımdaki kodu revize etmiştim. Ordan tekrar deneyiniz.

 

[bebar]

hocam dosya bulunamadı hatası verdi sizin için örnek bir dosya oluşturdum.
hakkınızı helal edin.