Resim silme

[6729626]

Aşağıdaki Makro ile; Başka bir dosyadan personel ismine göre sayfaya resim getiriyorum Buraya kadar sorun yok
Yalnız; Sayfada başka bir resim varsa makro çalıştığı zaman sayfadaki bu resimleri de siliyor.
Ve, her personel ismini değiştirdiğimde, kaydetmek gerekiyor, kaydetmezsem makro ikinci kez çalışmıyor.
Yardımlarınız için şimdiden teşekkür ediyorum. İyi çalışmalar.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim resim As Shape, resimyolu As String
Dim evn As Object, klasor As Object, res As Object
Set evn = CreateObject("scripting.filesystemobject")
Set klasor = evn.getfolder(ThisWorkbook.Path & "\PERSONEL_RESİMLERİ")
For Each resim In ActiveSheet.Shapes
resim.Delete
Next
For Each res In klasor.Files
If res.Name = Range("b2").Value & ".jpg" Then
resimyolu = ThisWorkbook.Path & "\PERSONEL_RESİMLERİ\" & res.Name
Range("H2").Select
ActiveSheet.Pictures.Insert(resimyolu).Select
With Selection.ShapeRange
.ScaleWidth 1.2, 0, 0
.ScaleHeight 1.01, 0, 0
End With
End If
Next res
Range("b3").Select
Set evn = Nothing
Set klasor = Nothing
Set res = Nothing
Set resim = Nothing
resimyolu = vbNullString
End Sub

 

[Ömer]

Merhaba,

For Each resim In ActiveSheet.Shapes
resim.Delete
Next

Yukarıdaki kodların yerine aşağıdaki gibi bir yapı kurarsanız sadece A1:A10 arasındaki resimleri siler.

For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next

 

[6729626]

Merhaba,

For Each resim In ActiveSheet.Shapes
resim.Delete
Next

Yukarıdaki kodların yerine aşağıdaki gibi bir yapı kurarsanız sadece A1:A10 arasındaki resimleri siler.

For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next

İlginiz İçin Teşekkürler Ama maalesef olmadı

 

[6729626]

Sadece h2 hücresi

Merhaba,

For Each resim In ActiveSheet.Shapes
resim.Delete
Next

Yukarıdaki kodların yerine aşağıdaki gibi bir yapı kurarsanız sadece A1:A10 arasındaki resimleri siler.

For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next

Yukarıdaki kodda; Sadeece h2 hücresine getirilen resmi silmek için revize yapabilirmiyiz?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Resim_Sil()
    Dim Resim As Object
    For Each Resim In ActiveSheet.Shapes
        If Not Intersect(Resim.TopLeftCell, Range("H2")) Is Nothing Then
            Resim.Delete
        End If
    Next
End Sub

 

[6729626]

Option Explicit Sub Resim_Sil() Dim Resim As Object For Each Resim In ActiveSheet.Shapes If Not Intersect(Resim.TopLeftCell, Range("H2")) Is Nothing Then Resim.Delete End If Next End Sub

Next

Private Sub Worksheet_Change(ByVal Target As Range)
Dim resim As Shape, resimyolu As String
Dim evn As Object, klasor As Object, res As Object
Set evn = CreateObject("scripting.filesystemobject")
Set klasor = evn.getfolder(ThisWorkbook.Path & "\PERSONEL_RESİMLERİ")

" For Each resim In ActiveSheet.Shapes
resim.Delete
Next "

For Each res In klasor.Files
If res.Name = Range("b2").Value & ".jpg" Then
resimyolu = ThisWorkbook.Path & "\PERSONEL_RESİMLERİ\" & res.Name
Range("H2").Select
ActiveSheet.Pictures.Insert(resimyolu).Select
With Selection.ShapeRange
.ScaleWidth 1.2, 0, 0
.ScaleHeight 1.01, 0, 0
End With
End If
Next res
Range("b3").Select
Set evn = Nothing
Set klasor = Nothing
Set res = Nothing
Set resim = Nothing
resimyolu = vbNullString
End Sub

Yukarıda " İşaretli olan kodları aktif sayfada, sadece H2 hücresindeki resimi silecek şekilde revize etmek istiyorum.
Yukarıda verilen kodlar maalesef olmadı, Birde; Personel isimlerini değiştirdiğimde sayfayı kaydetmeden resimler gelmiyor.
Yardımlarınız ve ilginiz için tekrar tyeşekkürler.

 

[Korhan Ayhan]

Ben denediğimde oluyor. Demek ki sizin dosyanızda bilmediğimiz bir durum var.

Bunun için örnek dosyanızı paylaşmalısınız.

 

[6729626]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim resim As Shape, resimyolu As String
Dim evn As Object, klasor As Object, res As Object
Set evn = CreateObject("scripting.filesystemobject")
Set klasor = evn.getfolder(ThisWorkbook.Path & "\PERSONEL_RESİMLERİ")

" For Each resim In ActiveSheet.Shapes
resim.Delete
Next "

For Each res In klasor.Files
If res.Name = Range("b2").Value & ".jpg" Then
resimyolu = ThisWorkbook.Path & "\PERSONEL_RESİMLERİ\" & res.Name
Range("H2").Select
ActiveSheet.Pictures.Insert(resimyolu).Select
With Selection.ShapeRange
.ScaleWidth 1.2, 0, 0
.ScaleHeight 1.01, 0, 0
End With
End If
Next res
Range("b3").Select
Set evn = Nothing
Set klasor = Nothing
Set res = Nothing
Set resim = Nothing
resimyolu = vbNullString
End Sub

Yukarıda " İşaretli olan kodları aktif sayfada, sadece H2 hücresindeki resimi silecek şekilde revize etmek istiyorum.
Yukarıda verilen kodlar maalesef olmadı, Birde; Personel isimlerini değiştirdiğimde sayfayı kaydetmeden resimler gelmiyor.
Yardımlarınız ve ilginiz için tekrar tyeşekkürler.

 

[6729626]

Ben denediğimde oluyor. Demek ki sizin dosyanızda bilmediğimiz bir durum var.

Bunun için örnek dosyanızı paylaşmalısınız.

Dosya ektedir. Tekrar Teşekkürer. Allah Razı Olsun.

 

[Korhan Ayhan]

Eklediğiniz dosya şifreli.

Lütfen forum kurallarını okuyunuz.

Forum Kuralları

Üyelik & Kisisel Bilgileriniz & Üyelik İptali Bilgi Gizliliği: - Foruma üye olurken girdiğiniz kişisel bilgiler sadece forum adminleri tarafından görülecektir. Girmiş olduğunuz bilgileri istediğiniz zaman degiştirebilirsiniz. (kullanıcı adı hariç) Teknik düzenlemeler ve denemeler için Adminler...

www.excel.web.tr

 

[6729626]

Eklediğiniz dosya şifreli.

Lütfen forum kurallarını okuyunuz.

Forum Kuralları

Üyelik & Kisisel Bilgileriniz & Üyelik İptali Bilgi Gizliliği: - Foruma üye olurken girdiğiniz kişisel bilgiler sadece forum adminleri tarafından görülecektir. Girmiş olduğunuz bilgileri istediğiniz zaman degiştirebilirsiniz. (kullanıcı adı hariç) Teknik düzenlemeler ve denemeler için Adminler...

www.excel.web.tr

Çok özür diliyorum Şifre: Konmer

 

[Korhan Ayhan]

Eski kodu silip aşağıdaki kodu deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Resim As Variant, Yol As String, Seperator As String
    
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    
    For Each Resim In ActiveSheet.Shapes
        If Resim.Type = 11 Then
            If Not Intersect(Resim.TopLeftCell, Range("H2")) Is Nothing Then
                Resim.Delete
            End If
        End If
    Next
    
    Seperator = Application.PathSeparator
    Yol = ThisWorkbook.Path & Seperator & "PERSONEL_RESİMLERİ" & Seperator
    Resim = Yol & Target.Value & ".jpg"
    
    If Dir(Resim) <> "" Then
        Set Resim = ActiveSheet.Pictures.Insert(Resim)
        
        With Range("H2:L16")
            Resim.ShapeRange.LockAspectRatio = msoFalse
            Resim.Left = .Left
            Resim.Top = .Top
            Resim.Height = .Height
            Resim.Width = .Width
        End With
        
        Set Resim = Nothing
    End If
End Sub

 

[6729626]

Eski kodu silip aşağıdaki kodu deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Resim As Variant, Yol As String, Seperator As String
   
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
   
    For Each Resim In ActiveSheet.Shapes
        If Resim.Type = 11 Then
            If Not Intersect(Resim.TopLeftCell, Range("H2")) Is Nothing Then
                Resim.Delete
            End If
        End If
    Next
   
    Seperator = Application.PathSeparator
    Yol = ThisWorkbook.Path & Seperator & "PERSONEL_RESİMLERİ" & Seperator
    Resim = Yol & Target.Value & ".jpg"
   
    If Dir(Resim) <> "" Then
        Set Resim = ActiveSheet.Pictures.Insert(Resim)
       
        With Range("H2:L16")
            Resim.ShapeRange.LockAspectRatio = msoFalse
            Resim.Left = .Left
            Resim.Top = .Top
            Resim.Height = .Height
            Resim.Width = .Width
        End With
       
        Set Resim = Nothing
    End If
End Sub

ÇOK TEŞEKKÜRLER, SAĞOLUN.

 

[mekist]

@Korhan Ayhan Bey Merhaba

Userform üzerindeki image nesnesine resim çektiriyorum
Örneğin A2 hücre değişmesi durumunda image nesnesinde resim varsa silsin, yoksa işlem yapmasın ( varsa yoksa yapamadım)
Varsa yoksa yapamadığım için hata alıyorum
Nasıl düzenlemek gerekir

Deneyiniz.

Option Explicit

Sub Resim_Sil()
    Dim Resim As Object
    For Each Resim In ActiveSheet.Shapes
        If Not Intersect(Resim.TopLeftCell, Range("H2")) Is Nothing Then
            Resim.Delete
        End If
    Next
End Sub

 

[Korhan Ayhan]

@mekist,

Bu konudaki kodlar sayfadaki resimlerle ilgili bir konudur...

Yeni konu açarak sorunuzu sormanız daha uygun olacaktır.

Hatta konu açmadan önce forumda arama yaparsanız arşivde mutlaka aradığınız soruna ilişkin çözümler vardır.

 

[Bayram Çoban]

Merhaba,

For Each resim In ActiveSheet.Shapes
resim.Delete
Next

Yukarıdaki kodların yerine aşağıdaki gibi bir yapı kurarsanız sadece A1:A10 arasındaki resimleri siler.

For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next

Merhaba kardeşim yazmış olduğun bu makroyu bende kullanmaya çalışıyorum, ismi kontrol olan bir sayfada B62 hücreSİ içerisinde ki resmi, oluşturduğum clear butonu ile ve bu makroyu diğer makronun altına ekleyerek sildirmeye çalışyorum 1 kaç başarılı silmeden sonra ve tam bu noktada "For Each Resim In ActiveSheet.Shapes" hata veriyor. Sorun ne olabilir.

 

[Korhan Ayhan]

Hata aldığınız dosyayı paylaşma durumunuz varsa kontrol edebiliriz.