Nesne silme (kapalı dosyalarda)

[Erdinç FIRTINA]

Değerli Forum üyeleri,
Aşağıdaki kodlar ile bir sayfadaki nesneler(resimler) silinebiliyor. Kodlarda değişiklik yapılarak, bir klasör içinde çok sayıdaki kapalı dosyanın aynı sayfalarındaki (örneğin Sayfa2 lerde veya Sayfa1 lerde) nesnelerin silinmesi sağlanabilir mi ?

Yardımlarınız için şimdiden çok teşekkürler !!!

Sub NESNE_SİL()
Dim Nesne As Shape
For Each Nesne In ActiveSheet.Shapes
If Nesne.Type <> 8 And Nesne.Type <> 12 Then
Nesne.Delete
End If
Next
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub NESNE_SİL()
    Dim Yol As String, Dosya As String, Kitap As Workbook
    Dim Sayfa As Worksheet, Nesne As Shape
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    Yol = ThisWorkbook.Path & "\*.xls*"
 
    Dosya = Dir(Yol)
 
    Do While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Set Kitap = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & Dosya)
            For Each Sayfa In Kitap.Worksheets
                If Sayfa.Name = "Sayfa1" Or Sayfa.Name = "Sayfa2" Then
                    For Each Nesne In Sayfa.Shapes
                        If Nesne.Type <> 8 And Nesne.Type <> 12 Then
                            Nesne.Delete
                        End If
                    Next
                End If
            Next
            Kitap.Close True
        End If
        Dosya = Dir
    Loop
 
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Erdinç FIRTINA]

Sayın Korhan AYHAN,
Her zaman olduğu gibi yardımınızda yine gecikmediniz. Ancak ben düzenlediğiniz kodları ilgili klasörümün içindeki 'ana' adlı dosyama attığımda yapmak istediğimi başaramadım.
Bu nedenle de yardımlarınıza ihtiyaç duydum. Müsait olduğunuzda yardımcı olursanız çok mutlu olurum.
Her şey için teşekkürler !!!!

 

[Korhan Ayhan]

Kod içindeki "Yol...." ile başlayan bölümü aşağıdaki gibi değiştirip deneyin.

Yol = ThisWorkbook.Path & "\*.xls*"

 

[Erdinç FIRTINA]

Sayın Korhan AYHAN,
aşağıdaki ilgili satırda hata veriyor
Set Kitap = Workbooks.Open(Filename:=Dosya)

 

[halit3]

Alternatif kod:

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 ActiveSheet.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

 

[Erdinç FIRTINA]

Sayın halit3,

Çok çok teşekkürler ! Yüreğinize, beyninize, bileğinize sağlık !!!

Aşağıdaki satırda hata veriyor. Bakabilirseniz mutlu olurum.

Set wb = Workbooks.Open(Dosya)

 

[halit3]

Sayın halit3,

Çok çok teşekkürler ! Yüreğinize, beyninize, bileğinize sağlık !!!

Aşağıdaki satırda hata veriyor. Bakabilirseniz mutlu olurum.

Set wb = Workbooks.Open(Dosya)

6 nolu mesajdaki kodu güncelledim.

 

[Korhan Ayhan]

Merhaba,

Bende #2 nolu mesajımdaki kodu güncelledim. Deneyiniz.

 

[Erdinç FIRTINA]

Sayın Korhan AYHAN,
Çok teşekkür ederim.

 

[Erdinç FIRTINA]

Sayın Korhan AYHAN, Sayın Halit3,
Kapalı durumda olan yine aynı dosyaların aynı sayfalarında belirtilen sütunlarla ilgili ayarlar yapılabilir mi ?
Örneğin, kapalı olan dosyaların; a2:f500000, r2:t500000 arasındaki hücrelere 12 punto, bold, kırmızı yazılsın, kenar çizgileri olsun, ortaya yazılsın, sütun genişliği 25 olsun vb ölçütler belirlenebilir mi?

 

[Korhan Ayhan]

Merhaba,

Kapalı dosyaları açtığımız sürece herşeyi yapabilirsiniz. Bir sınırlama yoktur.

Aşağıdaki kodu kullanabilirsiniz. Ben 5000 satır için ayarladım. Satır sayısı artarsa yavaşlama yaşayabilirsiniz.

Sub NESNE_SİL()
    Dim Yol As String, Dosya As String, Kitap As Workbook
    Dim Sayfa As Worksheet, Nesne As Shape
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
 
    Yol = ThisWorkbook.Path & "\*.xls*"
 
    Dosya = Dir(Yol)
 
    Do While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Set Kitap = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & Dosya)
            For Each Sayfa In Kitap.Worksheets
                If Sayfa.Name = "Sayfa1" Or Sayfa.Name = "Sayfa2" Then
                    For Each Nesne In Sayfa.Shapes
                        If Nesne.Type <> 8 And Nesne.Type <> 12 Then
                            Nesne.Delete
                        End If
                    Next
                    Sayfa.Range("A2:F2,R2:T2").ColumnWidth = 25
                    With Sayfa.Range("A2")
                        .Font.Size = 12
                        .Font.Bold = True
                        .Font.ColorIndex = 3
                        .HorizontalAlignment = xlCenter
                        .Borders.LineStyle = 1
                        .Copy Sayfa.Range("A2:F5000,R2:T5000")
                    End With
                End If
            Next
            Kitap.Close True
        End If
        Dosya = Dir
    Loop
 
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Erdinç FIRTINA]

Sayın Korhan AYHAN,
Çok çok teşekkür ederim. Aslında sormak istediğim, nesne sil makrosu içinde olması ile ilgili değidi. Yani, anlatttığım ayarları ayrı bir makro ile yapmaktı. Herhalde sorumu yanlış sordum. Ama aynı makro içinde de kullanabiliyorum. O nedenle işimi gördü.

Yardımlarınız için çok teşekkürler.

 

[Erdinç FIRTINA]

Sayın Korhan AYHAN,
Umarım yeni bir konu başlığı açmamakla kuralları bozmuyorum.

Kodlarla değişiklik yaparak kendime uyarlamaya çalıştım. Ancak, birleştirilmiş hücre renklendirmesini de belirlediğim alanda yapmasını istiyorum. Çünkü, satır sayısı çok fazla.


Aşağıdaki kod satırlarında değişiklik yapmam gerektiğini düşünüyorum ancak nasıl bir değişiklik yapmam gerekiyor?

(For Each cell In ActiveSheet.UsedRange
If cell.MergeCells = True Then cell.Interior.ColorIndex = 5)



Sub Hücre_ayır_biçimlendir()
Dim Yol As String, Dosya As String, Kitap As Workbook
Dim Sayfa As Worksheet, Nesne As Shape
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Yol = ThisWorkbook.Path & "\*.xls*"
Dosya = Dir(Yol)
Do While Dosya <> ""
If Dosya <> ThisWorkbook.Name Then
Set Kitap = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & Dosya)
For Each Sayfa In Kitap.Worksheets
If Sayfa.Name = "Sheet1" Or Sayfa.Name = "Sayfa1" Then

For Each cell In ActiveSheet.UsedRange
If cell.MergeCells = True Then cell.Interior.ColorIndex = 5
Next

Sayfa.Range("A2:T2").ColumnWidth = 5
With Sayfa.Range("A2:T5000")
.Font.Size = 8
.Font.Bold = False
.Font.ColorIndex = 1
'.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.Borders.LineStyle = 1
End With
End If
Next
Kitap.Close True
End If
Dosya = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ahmet ÖZGÜR]

Alternatif kod:

Dim Kaynak As String


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, fs As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
For Each Dosya In fs
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 ActiveSheet.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
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Üstad bu kodda sayfa sınırlaması yapmasak sayfa ismi kısıtlaması da yapmasak kaç tane sayfa varsa hepsinden silse.
Ayrıca World dosyaları için bir kod varmıdır?

 

[Ahmet ÖZGÜR]

Klasör içerisinde World olunca hata veriyor


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

 

[halit3]

Üstad bu kodda sayfa sınırlaması yapmasak sayfa ismi kısıtlaması da yapmasak kaç tane sayfa varsa hepsinden silse.
Ayrıca World dosyaları için bir kod varmıdır?

kod:

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 ActiveSheet.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

 

[Ahmet ÖZGÜR]

kod:

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 ActiveSheet.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

Üstad sayfa isimlerinin yanindaki PR ile başlayanlar olduğu için mi silmiyor acaba? ve bazı excel çalışma kitapları 100 sayfaya kadar çıkabiliyor



uzun sayfalara bir örnek daha

 

[halit3]

bunu bir dene

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

 

[halit3]

olmaz ise bunu dene

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

For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).DrawingObjects.Delete
Next

ActiveWorkbook.Save
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