Koşullu içerik oluşturma

[havva1981]

Merhaba, alttaki kod a sütunundaki değeri kontrol ederek D sütununda resim gösermekte. Örneğin A1 sütünunda "ali" yazıyorsa "D1" sütununda belirtilen klasördeki "ali.png" dosyasını göstermekte.
Sorun şu: A1 sütünunda "ali" yazıyor fakat klasörde resmi yoksa örneğin"resimyok.png" dosyasını göstersin. Aynı zamanda a1 sütunu boş ise yine "resimyok.png" dosyasını göstersin.
Not: Üye isimleri alt alta uzayıp gitmektedir. Nasıl yapabilirim? Saygılar.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
'hata kontrolü
On Error GoTo çıkış
Dim ResimYolu As Variant
Dim Resim As Object
'Resimleri Sil
ActiveSheet.DrawingObjects.Delete
'Resim Yolu
For satir = 2 To 65536
ResimYolu = ActiveWorkbook.Path & "\" & Range("a" & satir) & ".png"
'Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
'Resmi Boyutlandır
With Range("d" & satir)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
Next satir

çıkış:
 ActiveSheet.DrawingObjects.Select
 Selection.OnAction = "PictureBigSmall"
 ActiveCell.Select
End Sub

 

[Asri]

Aşağıdaki şekilde deneyiniz

Dim ResimYolu As Variant
Dim Resim As Object

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
       Set ds = CreateObject("Scripting.FileSystemObject")
       'hata kontrolü
       On Error GoTo cikis

       'Resimleri Sil
       ActiveSheet.DrawingObjects.Delete
       sonsatir = Cells(Rows.Count, "A").End(3).Row
       'Resim Yolu
       For satir = 2 To sonsatir
          ResimYolu = ActiveWorkbook.Path & "\" & Range("a" & satir) & ".png"
          If ds.FileExists(ResimYolu) Then
             ResimYolu = ActiveWorkbook.Path & "\" & Range("a" & satir) & ".png"
          Else
             ResimYolu = ActiveWorkbook.Path & "\" & "resimyok.png"
          End If
             
         'Resmi oluştur
         Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
         'Resmi Boyutlandır
         With Range("d" & satir)
            Resim.Top = .Top
            Resim.Left = .Left
            Resim.Height = .Height
            Resim.Width = .Width
         End With
       Next satir

cikis:
       If sonsatir > 1 Then
          ActiveSheet.DrawingObjects.Select
          Selection.OnAction = "PictureBigSmall"
          ActiveCell.Select
       End If
End Sub

 

[havva1981]

Çok çok teşekkür ederim değerli katkınız için. Sorunsuz şekilde çalıştı.