Soru Makro ile çalışma kitabındaki değerleri formülden kurtarma, bazı sayfaları silme msj uyarısız

[mbugra]

Öncelikle herkese iyi günler dilerim...

Bir çalışma kitabı ve içerisinde 40 civarında çalışma sayfası var. Yapmak istediklerim;
1.İlk olarak tüm sayfaların korumasını uyarı msj almadan kaldırmak,
2.Sonrasında tüm sayfaları kopyalayıp özel yapıştır ile değerleri ve biçimleri yapıştırmak,
3.Sayfalarda bulunan hücre değerlerinden “0” olanları silme, (Sadece hücre değeri 0 olan içerisinde sıfır geçen değil)
4.Sayfalar içerisinde bulunan özel şekil ve nesneler var bunların silinmesi,
5.Çalışma kitabı içerisinde bulunan bazı sayfaların tamamen silinmesi,
6.Son olarak çalışma kitabının yeni çalışma kitabına makrosuz olarak kaydedilmesi, kopya olan kitaba aynı kitap isminin verilmesiyeni kitabın kapanması. Ancak asıl çalışma kitabının makrolarının ve içeriğinin bozulmaması.

Ben bunların bir kısmını formdan faydalanarak yaptım ancak olmadı. Örneğin sayfaların silinmesi sırasında uyarı msj geldi tek tek tıklamayla silmek gibi, başka çalışma kitabına aktarılırken bu sayfa da değişikler var kaydetmek istiyormusun diye msj ekranı çıkıyor, benim istediğim hiç bir uyarı almadan yukarıda belirtilen koşullara göre yapması

Yardımlarınız için şimdiden çok teşekkür ederim saygılarımla...

 

[mbugra]

Değerli hocalarım ve arkadaşlar sorunu bir türlü istediğim gibi çözemedim, vaktiniz olduğunda yol gösterirseniz memnun olurum

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Dosyayi_Makrosuz_Formulsuz_Farkli_Kaydet()
    Dim Aktif_Dosya As Workbook, Sayfa As Worksheet, Yeni_Dosya As Workbook
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    Set Aktif_Dosya = ThisWorkbook
    
    For Each Sayfa In Aktif_Dosya.Worksheets
        Sayfa.Unprotect "12345"
    Next

    Aktif_Dosya.Sheets.Copy
    
    Set Yeni_Dosya = ActiveWorkbook

    For Each Sayfa In Yeni_Dosya.Worksheets
        With Sayfa
            .Select
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells.PasteSpecial xlPasteFormats
            .Cells.Replace 0, "", xlWhole
            .DrawingObjects.Delete
            .Range("A1").Select
        End With
    Next
    
    Sheets(1).Select
    
    Yeni_Dosya.Sheets(Array("Sayfa5", "Sayfa10", "Sayfa15")).Delete
    
    Yeni_Dosya.SaveAs Aktif_Dosya.Path & Application.PathSeparator & CreateObject("Scripting.FileSystemObject").GetBaseName(Aktif_Dosya.Name), 51
    
    Yeni_Dosya.Close
    
    For Each Sayfa In Aktif_Dosya.Worksheets
        Sayfa.Protect "12345"
    Next
    
    Set Yeni_Dosya = Nothing
    Set Aktif_Dosya = Nothing
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mbugra]

Deneyiniz.

Option Explicit

Sub Dosyayi_Makrosuz_Formulsuz_Farkli_Kaydet()
    Dim Aktif_Dosya As Workbook, Sayfa As Worksheet, Yeni_Dosya As Workbook
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
   
    Set Aktif_Dosya = ThisWorkbook
   
    For Each Sayfa In Aktif_Dosya.Worksheets
        Sayfa.Unprotect "12345"
    Next

    Aktif_Dosya.Sheets.Copy
   
    Set Yeni_Dosya = ActiveWorkbook

    For Each Sayfa In Yeni_Dosya.Worksheets
        With Sayfa
            .Select
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells.PasteSpecial xlPasteFormats
            .Cells.Replace 0, "", xlWhole
            .DrawingObjects.Delete
            .Range("A1").Select
        End With
    Next
   
    Sheets(1).Select
   
    Yeni_Dosya.Sheets(Array("Sayfa5", "Sayfa10", "Sayfa15")).Delete
   
    Yeni_Dosya.SaveAs Aktif_Dosya.Path & Application.PathSeparator & CreateObject("Scripting.FileSystemObject").GetBaseName(Aktif_Dosya.Name), 51
   
    Yeni_Dosya.Close
   
    For Each Sayfa In Aktif_Dosya.Worksheets
        Sayfa.Protect "12345"
    Next
   
    Set Yeni_Dosya = Nothing
    Set Aktif_Dosya = Nothing
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Hocam öncelikle ilgi ve alakanızdan dolayı çok teşekkür ederim…

Düzenlemiş olduğunuz makro eksiksiz olarak çalıştı.

Ancak; benim eksik anlattığım detaylarda sorun var.

1.Makro çalıştığında biçimlerde kaymalar oldu, aslında biçimi hiç işin katmayabilirim biçimler olduğu gibi kalsın.
2.Değer yapıştırmada ve hücre değeri "0" sıfır olanları silmede de problem yok makro tam olarak çalışıyor.
3.Nesneleri silmede de sorun yok ama sayfaların alt kısımlarıda düzenleyenlere ait bilgilerin olduğu metin kutuları var bunlarda silindiği için çıktı alırken tekrar bunları elle yazmam gerekecek (Tabiki makro ile halledemezsem)
4.Hocam size örnek çalışma kitabını ekliyorum,

Sonuç olarak, biçimlerin olduğu gibi kalması nesenelerin silinmesi sadece sayfadaki çizelgelerin alt kısımlarında ad soyad yazılı metin kutularının olduğu gibi kaldığını sağlarsam tam olacak. Makroda düzenleme yapabilirseniz çok sevinirim.

 

[mbugra]

Sub Dosyayi_Makrosuz_Formulsuz_Farkli_Kaydet()
    Dim Aktif_Dosya As Workbook, Sayfa As Worksheet, Yeni_Dosya As Workbook
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
   
    Set Aktif_Dosya = ThisWorkbook
   
    For Each Sayfa In Aktif_Dosya.Worksheets
        Sayfa.Unprotect "12345"
    Next

    Aktif_Dosya.Sheets.Copy
   
    Set Yeni_Dosya = ActiveWorkbook

    For Each Sayfa In Yeni_Dosya.Worksheets
        With Sayfa
            .Select
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells.Replace 0, "", xlWhole
           
           
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If Picture.TopLeftCell.Row >= 1 And Picture.TopLeftCell.Row <= 4 Then
Picture.Delete

End If
Next Picture
           
            .Range("A1").Select
           
        End With
    Next
   
    Sheets(1).Select
   
    Yeni_Dosya.Sheets(Array("Sayfa2", "Sayfa3", "Sayfa4")).Delete
   
    Yeni_Dosya.SaveAs Aktif_Dosya.Path & Application.PathSeparator & CreateObject("Scripting.FileSystemObject").GetBaseName(Aktif_Dosya.Name), 51
   
    Yeni_Dosya.Close
   
    For Each Sayfa In Aktif_Dosya.Worksheets
        Sayfa.Protect "12345"
    Next
   
    Set Yeni_Dosya = Nothing
    Set Aktif_Dosya = Nothing
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    MsgBox "İşlem Tamamlanmış, Masa Üstüne Formülsüz Olarak Kopyalanmıştır...", vbInformation
End Sub

 

[mbugra]

Korhan Ayhan Hocam yardımınız için çok teşekkür ederim sizin kod üzerinden devam ettim değişiklik yaparak çözdüm. Emeğinize sağlık