• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Resim silme

6

6729626

Katılım
31 Aralık 2005
Mesajlar
131
Excel Vers. ve Dili
Excel 2007 Türkçe
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
 
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.
Kod: 
For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next
 
Ömer' Alıntı:
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.
Kod: 
For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next
Genişletmek için tıkla ...
İlginiz İçin Teşekkürler Ama maalesef olmadı
 
Sadece h2 hücresi
Ömer' Alıntı:
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.
Kod: 
For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next
Genişletmek için tıkla ...
Yukarıdaki kodda; Sadeece h2 hücresine getirilen resmi silmek için revize yapabilirmiyiz?
 
Deneyiniz.

C++: 
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' Alıntı:
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
Genişletmek için tıkla ...
Korhan Ayhan' Alıntı:
Next
Genişletmek için tıkla ...




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.
 
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' Alıntı:
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.
Genişletmek için tıkla ...
 

Ekli dosyalar

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 www.excel.web.tr
 
Korhan Ayhan' Alıntı:
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 www.excel.web.tr
Genişletmek için tıkla ...
Çok özür diliyorum Şifre: Konmer
 
Eski kodu silip aşağıdaki kodu deneyiniz.

C++: 
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
 
Korhan Ayhan' Alıntı:
Eski kodu silip aşağıdaki kodu deneyiniz.

C++: 
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
Genişletmek için tıkla ...
ÇOK TEŞEKKÜRLER, SAĞOLUN.
 
@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

Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
 
@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.
 
Ömer' Alıntı:
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.
Kod: 
For Each resim In ActiveSheet.Shapes
    If Not Intersect(resim.TopLeftCell, Range("A1:A10")) Is Nothing Then
        resim.Delete
    End If
Next
Genişletmek için tıkla ...
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.
 
Hata aldığınız dosyayı paylaşma durumunuz varsa kontrol edebiliriz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst