çoklu resim ekleme

[theonlyone]

Herkese merhabalar;

Ek' te bulunan dosyada yeşil satırları değiştirince çıkan değere göre ilgili kutuya resim eklemek istiyorum. Forumdaki konuları okudum hepsinde tek bir değişkene göre resim ekleniyordu. ekteki excel dosyasında iki farklı değişkene iki resim eklemek istiyorum.

yardımcı olabilirseniz sevinirim.

 

[Korhan Ayhan]

Eklediğiniz klasör içindeki hangi resim hangi hücreye eklenecek belli değil.

Eklenecek resimlerin adı hücredeki değerlerle eşleşirse resimleri excel sayfasına almak kolaylaşır.

Aşağıdaki linkten faydalanabilirsiniz.

http://www.excel.web.tr/f48/gorsel-hucresine-resim-ekleme-sorunu-t149966.html

 

[theonlyone]

açıklama

Öncelikle ilginiz için teşekkür ederim.

Biraz daha açıklık getirmek için bir dosya ekledim. Bu konuda yardımcı olabilirseniz sevinirim.

Çünkü incelediğim konularda birebir karşılığına gelen hücreye resim ekleniyor. farklı hücrelere resim getirme tam anlamıyla yok. Teşekkürler.

 

[Korhan Ayhan]

Listeniz aşağıya doğru uzuyor mu?

 

[theonlyone]

Evet liste uzayacaktır. İlk kısmın mantığını anlayıp diğerlerini kendim eklerim diye düşünmüştüm. 20-30 adet çeşitli ürün olacaktır.

Teşekkürler.

 

[theonlyone]

Yardımcı olabilir misiniz?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Resimleri_Sil()
    Dim Resim As Object
    
    For Each Resim In ActiveSheet.Shapes
        If TypeName(ActiveSheet.Shapes(Resim.Name).OLEFormat.Object) = "Picture" Then
            Resim.Delete
        End If
    Next
End Sub

Sub Tüm_Resimleri_Yenile()
    Dim Yol As String, Dosya As String, Resim As Object, X As Long, Son As Long
    Dim RTop As Double, RLeft As Double, RWeight As Double, RHeight As Double
 
    Resimleri_Sil
    
    Son = Cells(Rows.Count, 3).End(3).Row
        
    For X = 6 To Son Step 6
        Yol = ThisWorkbook.Path & "\"
        Dosya = Yol & Cells(X, "C").Value & ".jpg"
        If Dir(Dosya) <> "" Then
            Set Resim = ActiveSheet.Pictures.Insert(Dosya)
            
            Cells(X, "G").Select
            If Selection.Cells.Count = 1 Then
                RTop = Selection.Top + 0.5
                RLeft = Selection.Left + 0.5
                RWeight = Selection.Width - 1
                RHeight = Selection.Height - 1
                Resim.ShapeRange.LockAspectRatio = msoFalse
            Else
                RTop = Selection.Top - 18 + Selection.Height / 5
                RLeft = Selection.Left + 0.5
                RWeight = Selection.Width - 0.5
                RHeight = Selection.Height - 1
            End If
            
            With Resim
                .Top = RTop
                .Left = RLeft
                .Width = RWeight
                .Height = IIf(RHeight = 0, Resim.Height, RHeight)
            End With
            
            Set Resim = Nothing
        End If
    Next

    Range("A1").Select

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[theonlyone]

Korhan bey kod çalıştı. Şimdi tüm listeye uygulayacağım. Şu anlık problem yok. İlginiz için teşekkür ederim.