Çözüldü Resim Silme

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

fenetre

Yeni Üye
Katılım
28 May 2020
Mesajlar
3
En iyi yanıt
0
Puanları
1
Yaş
50
Konum
karaman
Ad Soyad
mehmet sayman
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
 

fenetre

Yeni Üye
Katılım
28 May 2020
Mesajlar
3
En iyi yanıt
0
Puanları
1
Yaş
50
Konum
karaman
Ad Soyad
mehmet sayman
Sanırım iki şeyi yanlış yaptım1: Soru bölümünde açmam gerekiyordu 2 Başlığı; Resim Silme yazacakken, Resim Silem diye yazmışım. Özür.
 

muygun

Uzman
Katılım
19 Ağu 2018
Mesajlar
206
En iyi yanıt
23
Puanları
28
Konum
Excel 2003
Ad Soyad
Mustafa UYGUN
Office Versiyon
Office 2003
Merhaba;

kodlardaki;

For Each resim In ActiveSheet.Shapes
resim.Delete
Next

kısmının yerine;

Set Alan = Range("a6:ac57")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing


Kodlarını uygulayarak deneyin.
Set Alan = Range("a6:ac57") kısmındaki a6:ac57 aralığını (resim varsa silinecek alan) kendinize göre düzenleyin.

İyi çalışmalar.i
 

fenetre

Yeni Üye
Katılım
28 May 2020
Mesajlar
3
En iyi yanıt
0
Puanları
1
Yaş
50
Konum
karaman
Ad Soyad
mehmet sayman
Merhaba;

kodlardaki;

For Each resim In ActiveSheet.Shapes
resim.Delete
Next

kısmının yerine;

Set Alan = Range("a6:ac57")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing


Kodlarını uygulayarak deneyin.
Set Alan = Range("a6:ac57") kısmındaki a6:ac57 aralığını (resim varsa silinecek alan) kendinize göre düzenleyin.

İyi çalışmalar.i
Çok Teşekkürler
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Üst Alt