Nesne silme (kapalı dosyalarda)

[Ahmet ÖZGÜR]

Bilgisayar başına geçince deneyip size bilgi veririm Halit bey


Tapatalk kullanarak iPhone aracılığıyla gönderildi

 

[Ahmet ÖZGÜR]

bunu bir dene

Sub nesnelerisil()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files

Uzanti = fL.GetExtensionName(Dosya.Name)
If Uzanti = "xls" Or Uzanti = "xlsx" Or Uzanti = "xlsm" Then

If ThisWorkbook.Name <> Dosya.Name Then
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
deg = 0
For i = 1 To ActiveWorkbook.Sheets.Count
'If Sheets(i).Name = "Sayfa1" Or Sheets(i).Name = "Sayfa2" Then
Dim Picture As Object
For Each Picture In Sheets(i).Shapes
If Picture.Type <> 8 And Picture.Type <> 12 Then
Picture.Delete
deg = 1
End If
Next
'End If
Next
If deg = 1 Then
ActiveWorkbook.Save
End If
ActiveWorkbook.Close
End If
End If

Next
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Bu bütün sayfalardaki resimleri sildi.

Teşekkür ederim Halit Bey.

 

[halit3]

Teşekkürler iyi çalışmalar