Dosya yedeğini alma

[Kavinsky]

Merhabalar, aşağıdaki kod

Önce repairverimlilik isimli makroyu çağırıyor bu makro formüller dahil herşeyi seçip düz veri olarak yapıştırıyor. Ardından bu dosyayı farklı kaydet yaparak arşive atıyor ve ardından mevcut olan dosyayı SıfırlaVerimlilik isimli makroyu çağırarak sıfırlıyor ve kaydediyor. Sıkıntı burada başlıyor. Çünkü mevcut dosyayı sıfırlayıp farklı kaydetmesi gerekirken aynı dosya üzerine kaydediyor hem de farklı kaydediyor. Haliyle mevcut dosyada sıfırlandıktan sonra formüllerin hepsi gidiyor ve veriye dönüşüyor ve sistem çalışmıyor. Bir yerde hata var ama nerede çözemedim. Yardımlarınızı rica ediyorum

Option Explicit

Sub YedekleVerimlilik()

    Dim My_Folder As String
    Call repairverimlilik
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    My_Folder = "Z:\data\30_URETIM_ORTAK\01_ÜRETİM_RAPOR\ARŞİV\" & Format(Date, "yyyy") & "\" & Format(Date, "mmmm") & "\"

    If Dir(My_Folder, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & My_Folder & """")
    End If


    ThisWorkbook.Sheets.Copy
    
    ActiveWorkbook.SaveAs My_Folder & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    ActiveWorkbook.Close

Call SıfırlaVerimlilik
   Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ThisWorkbook.Save
    Application.Quit
End Sub

 

[meda58]

Merhabalar, aşağıdaki kod

Önce repairverimlilik isimli makroyu çağırıyor bu makro formüller dahil herşeyi seçip düz veri olarak yapıştırıyor. Ardından bu dosyayı farklı kaydet yaparak arşive atıyor ve ardından mevcut olan dosyayı SıfırlaVerimlilik isimli makroyu çağırarak sıfırlıyor ve kaydediyor. Sıkıntı burada başlıyor. Çünkü mevcut dosyayı sıfırlayıp farklı kaydetmesi gerekirken aynı dosya üzerine kaydediyor hem de farklı kaydediyor. Haliyle mevcut dosyada sıfırlandıktan sonra formüllerin hepsi gidiyor ve veriye dönüşüyor ve sistem çalışmıyor. Bir yerde hata var ama nerede çözemedim. Yardımlarınızı rica ediyorum

Option Explicit

Sub YedekleVerimlilik()

    Dim My_Folder As String
    Call repairverimlilik
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    My_Folder = "Z:\data\30_URETIM_ORTAK\01_ÜRETİM_RAPOR\ARŞİV\" & Format(Date, "yyyy") & "\" & Format(Date, "mmmm") & "\"

    If Dir(My_Folder, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & My_Folder & """")
    End If


    ThisWorkbook.Sheets.Copy
   
    ActiveWorkbook.SaveAs My_Folder & Replace(ThisWorkbook.Name, "xlsm", "xlsx"), 51
    ActiveWorkbook.Close

Call SıfırlaVerimlilik
   Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ThisWorkbook.Save
    Application.Quit
End Sub

kitabın ana sayfasına (Bu çalışma kitabı) kaytedin
D ye yedek isminde klasöre yedekleyecektir
yedekten açarken şifre 1234 isterseniz bunu değiştirebilirsiniz

Private Sub Workbook_BeforeClose(Cancel As Boolean)


Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yer = "D:\YEDEK\"
For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya = Mid(ThisWorkbook.Name, 1, i - 1)
uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next
ActiveWorkbook.Password = "1234"
ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
Kayıt_Yeri = yer & Yedek_Dosya_Adı
On Error Resume Next
If Dir(yer) = "" Then MkDir yer
On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
ActiveWorkbook.Password = ""
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "Ajandam Uyarı Sistemi"
Application.DisplayAlerts = True


End Sub

 

[Kavinsky]

Öncelikle çok teşekkür ederim emeğiniz için. Sanırım bu hazır bir kod ve açıklamada yazdığım ihtiyaçları ne yazık ki karşılamadı. Fakat yine de çok teşekkürler.