Makro ile resim getirme

[besen]

Merhaba sayfada baktım, konuyla ilgili örnekler var ama benim örneğime uygun göremedim.
Bilgisayarımdaki klasörde mevcut resimler var.
Excel listemde XX212101104 003 kod şeklinde ürünlerim var. Klasörde bu ürün koda ait renk ve farklı kriterlere göre resimleri şöyle sınıflandırılmış durumda.
XX212101104 003
XX212101104 003_1
XX212101104 003_2
XX212101104 003_3
XX212101104 003_4
XX212101104 003_5

Ben ilgili klasörden exceldeki A kolonuna ait ürünlerin resimlerinin makroyla F kolonundan itibaren sırayla gelmesini istiyorum. Sizin önereceğiniz başka bir şekilde de olabilir.
Yardım ricasıyla.
Saygılar.

 

[Korhan Ayhan]

Resimleri ekleyince ürün sayısına göre dosya boyutu büyük ihtimalle çok şişecektir.

Bunun yerine seçtiğiniz ürüne ait resmi çağırmak daha mantıklı olabilir.

 

[Mahmut Kök]

Sizin örneğinizde A2 hücresindeki ürün numarasına göre istediğiniz işlemi aşağıdaki kodlarla yapabilirsiniz. Sadece ana ürün numarası yeterli. xxx_1 , xxx_2 gibi diğer ürünleri kendisi ayarlıyor. En fazla 50 yan ürün olur diye bir dizi belirledim. Onu ihtiyaca göre düzenlersiniz.

Klasörü ve resim dosyalarının uzantılarını kontrol edin.

Kodları bir modüle yapıştırıp deneyebilirsiniz.

Diğer satırlar için kendinize uyarlarsınız. İyi çalışmalar...

Dim klasor As String

Sub resimleriGetir()

Belirli_Bir_Alandaki_Resimleri_Sil

klasor = "C:\SKU_resimler\"

Dim resimler() As String

Dim aranan As String
aranan = Range("A2").Text

resimler = dosyalar

'F = 6. sütun.
Dim sutun As Integer
sutun = 6

For i = 1 To 50

    If (Left(resimler(i), Len(aranan)) = aranan) Then
    
    Call resimEkle(resimler(i), sutun)
    sutun = sutun + 1
    
    End If

Next


End Sub


'Bu soruya verilen cevaplardan yararlanılmştır.
' https://www.excel.web.tr/threads/otomatik-resim-ekleme.170421/


Function dosyalar() As String()

Dim resimler(50) As String

Dim STR As Long, YL As String, DSY As String
STR = 1
YL = klasor
DSY = Dir(YL, vbNormal)
Do While DSY <> ""
With WorksheetFunction
If (GetAttr(YL & DSY) And vbNormal) = vbNormal Then

resimler(STR) = Replace(DSY, Right(DSY, Len(DSY) - _
.Find("*", .Substitute(DSY, ".", "*", Len(DSY) - Len( _
.Substitute(DSY, ".", "")))) + 1), "")
STR = STR + 1

End If: End With
DSY = Dir
Loop

dosyalar = resimler

End Function


Sub resimEkle(Resim As String, sutun As Integer)

'resimlerin bulunduğu klasörü yazıyoruz.
Dim resimyolu
resimyolu = klasor & Resim & ".png" 'Resim dosyalarının uzantısını buraya yazın. jpeg ise değiştirebilirsiniz.

Cells(2, sutun).Select
Selection.Offset(-1, 0) = Resim

ActiveSheet.Pictures.Insert(resimyolu).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Cells(2, sutun).Top
            .Left = Cells(2, sutun).Left
            .Width = Cells(2, sutun).Width
            .Height = Cells(2, sutun).Height
    End With

End Sub


Function Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
    
    Set Alan = Range("F1:M2")
    Alan.ClearContents
    
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
    
    Set Alan = Nothing
    
End Function

 

[besen]

Öncelikle çok teşekkür ederim.
resimleri koyduğumuz klasör makroya bu şekilde kaydettim.
klasor = "C:\Users\Bülent Esen\Desktop\resim\"

Makroyu çalıştırdım bu hatayı verdi.

resimler(STR) = Replace(DSY, Right(DSY, Len(DSY) - _
.Find("*", .Substitute(DSY, ".", "*", Len(DSY) - Len( _
.Substitute(DSY, ".", "")))) + 1), "")
STR = STR + 1

 

[besen]

Klasörü C'ye aldım şimdi çalıştı ancak sadece ilk satırdaki koda denk gelen resimler geliyor.

 

[besen]

Tekrar merhaba diğer satırları da hallettik. Ancak dosyayı maille gönderdiğim kişiler resimleri göremiyor.
Ekteki hatayı veriyor.
Teşekkür

 

[Mahmut Kök]

Aşağıdaki kodu ( resimEkle ) önceki ile değiştirerek deneyiniz. Bu yine ilk satır (A2) için geçerli, siz diğer satırlara uyarlarsınız.

Sub resimEkle(Resim As String, sutun As Integer)

'resimlerin bulunduğu klasörü yazıyoruz.
Dim resimyolu
resimyolu = klasor & Resim & ".png" 'Resim dosyalarının uzantısını buraya yazın. jpeg ise değiştirebilirsiniz.

Cells(2, sutun).Select
Selection.Offset(-1, 0) = Resim



Set rsm = ActiveSheet.Shapes.AddPicture(Filename:=resimyolu, _
    linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=Cells(2, sutun).Left, Top:=Cells(2, sutun).Top, Width:=Cells(2, sutun).Width, Height:=Cells(2, sutun).Height)



End Sub

 

[besen]

Merhaba bir arkadaşımız makroyu bu şekilde revize edip, tüm satırları dolduracak hale getirmişti.
Şimdi sizin yazdığınız değişikliği nasıl revize edeceğimi bilemedim. Bu makroda düzeltebilir misiniz.
Teşekkürler.


Dim klasor As String

Sub resimleriGetir()

Belirli_Bir_Alandaki_Resimleri_Sil

Dim k As Integer
For k = 2 To 500



klasor = "C:\resim\"

Dim resimler() As String


Dim aranan As String
aranan = Cells(k, 1).Text

resimler = dosyalar

'F = 6. sütun.
Dim sutun As Integer
sutun = 6

If Cells(k, 1).Text <> "" Then

For i = 1 To 500

If (Left(resimler(i), Len(aranan)) = aranan) Then

Call resimEkle(resimler(i), sutun, k)
sutun = sutun + 1

End If

Next

End If

Next

End Sub


'Bu soruya verilen cevaplardan yararlanılmştır.
' https://www.excel.web.tr/threads/otomatik-resim-ekleme.170421/


Function dosyalar() As String()

Dim resimler(500) As String

Dim STR As Long, YL As String, DSY As String
STR = 1
YL = klasor
DSY = Dir(YL, vbNormal)
Do While DSY <> ""
With WorksheetFunction
If (GetAttr(YL & DSY) And vbNormal) = vbNormal Then

resimler(STR) = Replace(DSY, Right(DSY, Len(DSY) - _
.Find("*", .Substitute(DSY, ".", "*", Len(DSY) - Len( _
.Substitute(DSY, ".", "")))) + 1), "")
STR = STR + 1

End If: End With
DSY = Dir
Loop

dosyalar = resimler

End Function


Sub resimEkle(Resim As String, sutun As Integer, k As Integer)

'resimlerin bulunduğu klasörü yazıyoruz.
Dim resimyolu
resimyolu = klasor & Resim & ".jpg" 'Resim dosyalarının uzantısını buraya yazın. jpeg ise değiştirebilirsiniz.



Cells(k, sutun).Select
'Selection.Offset(-1, 0) = Resim'






ActiveSheet.Pictures.Insert(resimyolu).Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Top = Cells(k, sutun).Top
.Left = Cells(k, sutun).Left
.Width = Cells(k, sutun).Width
.Height = Cells(k, sutun).Height
End With

i = i + 1

End Sub


Function Belirli_Bir_Alandaki_Resimleri_Sil()
Dim Resim As Picture, Alan As Range

Set Alan = Range("F1:M500")
Alan.ClearContents

For Each Resim In ActiveSheet.Pictures
If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
Resim.Delete
End If
Next

Set Alan = Nothing

End Function

 

[yahoucmay]

Merhabalar linkini paylastigim videoda

personel kimlik kartı çalışmasında belirli hücre aralığına resim eklenmesi belirli hücre aralığındaki resimlerin silinmesi tüm resimlerin değil sadece belirtilen resimlerin silinmesi konuları yer almakta umarım işine yarar göz atmanı tavsiye ederim

 

[besen]

Makroyla yapmaya çalıştığım şeyin daha doğrusunu ve tam istediğim halini, HYPERLINK(CONCATENATE("\\server\d7s\xxxx\DOCSAFE/";INDEX(Açıklama!A:A;MATCH(MID(A418;1;11)&".html"
formülüyle çözdüm. Linki tıkladığımda istediğim fotoğrafın orijinaline ulaşıyorum.
Linki tıklamadan hücre üstündeyken küçük görüntüsünü görmek mümkün mü acaba?

 

[yahoucmay]

açıklama alanına resim eklersen olur