Resim Makrosu'na İlave

[1Al2Ver]

Merhaba,

Aşağıdaki kod ile B2 hücresindeki isme göre "Veriler" sayfasında 52 nci sütunda kayıtlı resimleri Sayfa1'de, A1:A13 aralığına çağırıyorum,

Kod ile bu işlemin yanı sıra, Sayfa1'de B2 hücresine göre "Veriler" sayfasında 55 nci sütunda kayıtlı bir başka resmi, I1:I13 aralığına aynı anda getirmek istiyorum,

İsteğim özetle, "Veriler" sayfasında 52 ve 55 nci sütunlarda kayıtlı resimlerin, Sayfa1'de B2 hücresine göre, A1:A13 ve I1:I13 aralığına gelmesidir,

Teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBul As Range
Dim rngResimAlani As Range
Dim oRsm As Picture

If Target.Address = Range("B2").Address Then

Set rngResimAlani = Range("A1:A13")

Set rngBul = Sheets("Veriler").Columns(1).Find(Target, Lookat:=xlWhole)

If Not rngBul Is Nothing Then

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

If Len(rngBul.Offset(0, 52)) > 0 Then
If Len(Dir(rngBul.Offset(0, 52))) > 0 Then

Set oRsm = ActiveSheet.Pictures.Insert(rngBul.Offset(0, 52))

With oRsm
.Left = rngResimAlani.Left
.Top = rngResimAlani.Top
oran = .Width / .Height
.Height = rngResimAlani.Height
.Width = .Height * oran
End With

Range("A1") = Empty

Else
Range("A6") = "Kayıtlı Resim Yok"
End If
Else
Range("A6") = "Veriler Sayfasında Kayıt Yok"
End If

End If

Set rngResimAlani = Nothing
Set rngBul = Nothing
Set oRsm = Nothing

End If

End Sub

 

[1Al2Ver]

Merhaba,

Bu işlemin gerçekleşmesi için gereken kodu veya ilave kodu rica ediyorum,

Teşekkür ederim,

 

[hamitcan]

Bence bir dosya ekleseniz, daha fazla ilgilenen olabilir.