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.