Resmi Hücrenin Boyutuna Otomatik Ayarlama

[TEGCreative]

Merhabalar.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [D]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double

'ActiveSheet.DrawingObjects.Delete

ResimDosya = ActiveWorkbook.Path & "\" & Target.Value & ".jpg"

If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Target.Offset(0, 1)
t = .Top + 3
l = .Left + 3
w = .Width - 3
h = .Height - 3
End With

With p
.Top = t
.Left = l
.Width = w
.Height = h
End With

Set p = Nothing
End Sub

Üstte bulunan worksheet change kodu ile D sütununda değişen hücre değeri ile bir yan hücreye dosyamızın bulunduğu klasörden D sütununda girilen değer isimli resim geliyor. Benim istediğim ise tam olarak şu ;

1 - Bu kod worksheet change değil de ayrı bir makro ile olabilir mi ?
2 - Resimin boyutu her ne olursa olsun geleceği hücrenin boyutuna bürünebilir mi ?
3 - Kod sütun bazlı çalışarak bir yan hücreye resmi getiriyor. Ben ise Kodu 5-6 farklı SATIRDA çalıştırıp( Örneğin ; 5,10,15,20,25,30 numaraları satırlar) bir ÜST hücreye resmi getirmek istiyorum.Ne gibi değişiklikler yapılmalı ?

Yardımlarınızı bekliyor şimdiden teşekkürlerimi sunuyorum.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Resmin adının yazılı olduğu hücreyi seçip kodu çalıştırın.

Resim ilgili klasörde varsa seçtiğiniz hücrenin bir üst satırındaki hücreye resmi ekler.

Sub Resim_Ekle()
    Resim_Adi = ActiveWorkbook.Path & "\" & ActiveCell.Value & ".jpg"
    
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, ActiveCell.Offset(-1, 0)) Is Nothing Then
            Resim.Delete
        End If
    Next
    
    If Dir(Resim_Adi) = "" Then Exit Sub
    Set Resim = ActiveSheet.Pictures.Insert(Resim_Adi)
    
    With ActiveCell.Offset(-1, 0)
        t = .Top + 3
        l = .Left + 3
        w = .Width - 3
        h = .Height - 3
    End With
    
    With Resim
        .ShapeRange.LockAspectRatio = msoFalse
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
End Sub

 

[TEGCreative]

Sayın Korhan AYHAN hocam ; çok teşekkür ederim. Süpersiniz. ost: