HÜCRE BOŞSA DİĞER RESİMLERİ SİLİYOR

A

asimgurlu

Katılım
14 Temmuz 2021
Mesajlar
4
Excel Vers. ve Dili
excell 93
Merhabalar.

Bir çalışmamız var. Örnek olarak A21 hücresinde ki veriye göre B21 hücresine resim çağırıyor. Fakat A21'de ki veri silindiğinde tüm resimleri siliyor. Fakat ben sadece B21 hücresinde ki veri silinsin istiyorum. Gerekli düzenleme için yardımcı olabilir misiniz ?


Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [a:a]) Is Nothing Then Exit Sub


' hata kontrolü
On Error GoTo çıkış
'resimleri Sil

ActiveSheet.DrawingObjects.Delete
'Resim yolunun bulunması

Dim ResimYolu As Variant
Dim Resim As Object

For satır = 21 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("a" & satır) & ".jpg"


'Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)



'Resmi boyutlandır

With Range("b" & satır)
Resim.Top = .Top + 5
Resim.Left = .Left + 2
Resim.Height = .Height - 5
Resim.Width = .Width - 5



End With

Next satır

çıkış:
End Sub
 
B

Biolightant

Katılım
6 Mart 2024
Mesajlar
19
Excel Vers. ve Dili
Excel 2013 TR & Excel 2016 TR
Merhaba,

Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Sadece A yani 1. sütunda ve
    ' 20. satırdan büyük satırda ve
    ' Tek bir hücre seçildiyse çalış
    If Target.Column = 1 And Target.Row > 20 And Target.CountLarge = 1 Then

        ' Eski Foto varsa sil
        On Error Resume Next
            ActiveSheet.DrawingObjects("Foto-B" & Target.Row).Delete
        On Error GoTo 0

        ' "Foto Yok!" yazısı varsa sil
        If Range("B" & Target.Row).Value = "Foto Yok!" Then
            Range("B" & Target.Row).Value = ""
        End If
      
        ' A sütununda değişiklik yaptığımız hücrenin içeriğinde yazan isimle
        ' aynı isimde bir jpg dosyası olduğunu varsayıyoruz
        Dim imagePath As String
        imagePath = ActiveWorkbook.Path & "\" & Range("A" & Target.Row).Value & ".jpg"
      
        Dim MyJpg As Picture
      
        On Error GoTo jpgYok ' Eğer klasörde ve hücre içeriğiyle aynı isimde jpg dosyası yoksa direk jpgYok satırına git
        Set MyJpg = ActiveSheet.Pictures.Insert(imagePath) ' Sayfaya jpg dosyasını ekle
        On Error GoTo 0

        ' Resmin boyutlarını, konumunu ve Adını ayarlayalım
        With MyJpg
            .Top = Range("B" & Target.Row).Top + 2
            .Left = Range("B" & Target.Row).Left + 2
            .Height = Range("B" & Target.Row).Height - 4
            .Name = "Foto-B" & Target.Row
        End With
      
        ' Eğer resim genişliği hücre genişliğinden büyükse genişliği ayarla
        If MyJpg.Width > Range("B" & Target.Row).Width - 4 Then
            MyJpg.Width = Range("B" & Target.Row).Width - 4
        End If
    End If

    Exit Sub ' Hata filan olmadı, kodlar buraya kadar geldi, çıkış yapalım

jpgYok:
    ' A hücresi boş değilse (ismi olmayan bir jpg dosyası bulamayıp yok yazmasın diye)
    If Target.Value <> "" Then
        ' Foto Yok! yaz
        Range("B" & Target.Row).Value = "Foto Yok!"
    End If

End Sub
 
Son düzenleme:
B

Biolightant

Katılım
6 Mart 2024
Mesajlar
19
Excel Vers. ve Dili
Excel 2013 TR & Excel 2016 TR
Soru sahibi ortada yokken ve can sıkıntısından kodları biraz geliştirdim...

1. Aşama : Worksheet_SelectionChange

2. Aşama : Worksheet_Change

A20 hücresinden büyük TEK bir hücre SEÇİLDİĞİNDE​

A20 hücresinden büyük TEK bir hücre DEĞİŞTİRİLDİĞİNDE​

Veri doğrulama listesi oluşturulur:

Excel dosyasıyla aynı klasörde bulunan *.jpg

dosyaların isimleri bu listeye eklenir​

A Hücresine yazılan la aynı isimde

bir JPG fotosu Excel dosyasıyla aynı klasörde​

Kullanıcı isterse bu listeden bir isim seçebilir​

Varsa B hücresinde Foto GÖZÜKÜR

Yoksa B hücresinde Foto Yok! yazar​


C++: 
Option Explicit

'Biolight 2024 - Eppur Si Muove

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim file As String
    Dim validationList As String

    ' Sadece A yani 1. sütunda ve
    ' 20. satırdan büyük satırda ve
    ' Tek bir hücre seçildiyse çalış
    If Target.Column = 1 And Target.Row > 20 And Target.CountLarge = 1 Then
        ' Çalışma kitabının bulunduğu klasördeki tüm JPG dosyalarını listele
        file = Dir(ActiveWorkbook.Path & "\*.jpg")

        ' JPG dosyası hiç yoksa çıkış yap
        If file = "" Then Exit Sub

        ' Dosya isimlerini listeye ekle
        Do While file <> ""
            Dim fileName As String
            fileName = Left(file, Len(file) - 4) ' .jpg uzantısını çıkar

            ' Dosya isimlerini virgülle ayırarak ekle
            If validationList = "" Then
                validationList = fileName
            Else
                validationList = validationList & "," & fileName
            End If

            ' Bir sonraki dosyayı al
            file = Dir
        Loop

        ' A sütunundaki tüm veri doğrulama kurallarını siler
        On Error Resume Next
            Range("A:A").Validation.Delete
        On Error GoTo 0

        ' Seçilen hücreye veri doğrulama listesi uygula
        With Target.Validation
            .Delete ' Önceki doğrulama kurallarını sil
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                 xlBetween, Formula1:=validationList ' Yeni doğrulama listesi ekle
            .IgnoreBlank = True
            .InCellDropdown = True
            .ShowInput = False
            .ShowError = False ' Hata mesajını devre dışı bırak
        End With
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Sadece A yani 1. sütunda ve
    ' 20. satırdan büyük satırda ve
    ' Tek bir hücre seçildiyse çalış
    If Target.Column = 1 And Target.Row > 20 And Target.CountLarge = 1 Then

        ' Eski Foto varsa sil
        On Error Resume Next
            ActiveSheet.DrawingObjects("Foto-B" & Target.Row).Delete
        On Error GoTo 0

        ' "Foto Yok!" yazısı varsa sil
        If Range("B" & Target.Row).Value = "Foto Yok!" Then
            Range("B" & Target.Row).Value = ""
        End If
       
        ' A sütununda değişiklik yaptığımız hücrenin içeriğinde yazan isimle
        ' aynı isimde bir jpg dosyası olduğunu varsayıyoruz
        Dim imagePath As String
        imagePath = ActiveWorkbook.Path & "\" & Range("A" & Target.Row).Value & ".jpg"
       
        Dim MyJpg As Picture
       
        On Error GoTo jpgYok ' Eğer klasörde ve hücre içeriğiyle aynı isimde jpg dosyası yoksa direk jpgYok satırına git
        Set MyJpg = ActiveSheet.Pictures.Insert(imagePath) ' Sayfaya jpg dosyasını ekle
        On Error GoTo 0

        ' Resmin boyutlarını, konumunu ve Adını ayarlayalım
        With MyJpg
            .Top = Range("B" & Target.Row).Top + 2
            .Left = Range("B" & Target.Row).Left + 2
            .Height = Range("B" & Target.Row).Height - 4
            .Name = "Foto-B" & Target.Row
        End With
       
        ' Eğer resim genişliği hücre genişliğinden büyükse genişliği ayarla
        If MyJpg.Width > Range("B" & Target.Row).Width - 4 Then
            MyJpg.Width = Range("B" & Target.Row).Width - 4
        End If
    End If

    Exit Sub ' Hata filan olmadı, kodlar buraya kadar geldi, çıkış yapalım

jpgYok:
    ' A hücresi boş değilse (ismi olmayan bir jpg dosyası bulamayıp yok yazmasın diye)
    If Target.Value <> "" Then
        ' Foto Yok! yaz
        Range("B" & Target.Row).Value = "Foto Yok!"
    End If

End Sub
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Üst