Satır ve Sütunlara Makro Resim Çağırma

[teyadih]

Merhaba;

Ekte yer alan örnek şablonda görüldüğü üzere, J3 sütuna 1-2-3 rakamlarını yazarak tanımlı fotoğrafları sorunsuz çağırabildim fakat "sarı renk ile" renklendirdiğim tüm hücrelere" bu J3 hücresine yaptığımı yapmak istiyorum.
Önemle yardımlarınızı rica ederim.

 

[Muzaffer Ali]

Merhaba.

Kodlarınızı aşağıdakiler ile değiştirin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i
    If Not Intersect(Target, Range("B3:R17")) Is Nothing Then
    
        'Resimleri Sil
        'ActiveSheet.DrawingObjects.Delete
        On Error Resume Next
        ActiveSheet.Pictures(Target.ID).Delete
        If Err.Number = 1004 Then GoTo devam
        'Hata Kontrolü
        On Error GoTo çıkış
devam:
        
        'Resim Yolunun Bulunması
        Dim ResimYolu As String
        Dim Resim As Object
        ResimYolu = ActiveWorkbook.Path & "\" & Target & ".jpg"
        'Resmi Oluştur
        Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
        'Resim Boyutlandır
        With Target
            Resim.Top = .Top
            Resim.Left = .Left
            Resim.Height = .Height
            Resim.Width = .Width
            .ID = Resim.Name
        End With
çıkış:
    End If
End Sub

 

[teyadih]

Teşekkür ederim sayın dalgalikur elinize sağlık

 

[Muzaffer Ali]

Rica ederim. İyi çalışmalar.

 

[teyadih]

Merhaba arkadaşlar sayın dalgalikur tarafından güncellenen makro ile dosyadaki ilgili ek taleplerime ilişkin örnek klasörü ekte gönderiyorum. Umarım anlatabilmişimdir, umarım taleplerim yapılabilir isteklerdir. Teşekkür ederim

 

[teyadih]

Arkadaşlar benim için 1.ve 2.maddeler önemli 3 ile 4.madde olursa daha güzel olur