Sayfa Yedekleme

[1Al2Ver]

Merhaba,

Çalışma kitabımda bulunan "LİSTE" ve "ÇIKIŞ" sayfalarımın belirli aralıklarını, C:\LİSTE_YEDEKLERİ klasörüne ;

Aynı çalışma kitabında, ayrı 2 sayfa olarak yedeklemek istiyorum,

Ek'li örnek dosyamda detaylı açıklamalar bulunmaktadır,

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Konuyla ilgili çözüm arayışım devam etmektedir,

Görüş-Öneri ve Çözümlerinizi rica ediyorum,

Teşekkür ederim.

 

[Ömer]

Merhaba,

Eski kodları bozmadan ilave yaparak;

Sub Yedekle_Liste()

kaynak = "C:\LİSTE_YEDEKLERİ"
dosya_adı = ActiveWorkbook.Name
Sayfa_adı = ("LİSTE")
deger = Cells(1, "H").Value

If deger = "" Then
MsgBox "Liste'nin Tarihini Girmediniz !"
Exit Sub
End If

yeni_dosya_adı = deger
Dim ExcelSheet As Object
On Error Resume Next
CreateObject("Excel.Sheet").SaveAs kaynak & "\" & yeni_dosya_adı & ".xlsx"

Workbooks.Open kaynak & "\" & yeni_dosya_adı & ".xlsx"
yeni_dosya_adı = ActiveWorkbook.Name
Sheets(ActiveSheet.Name).Name = "LİSTE"

Windows(dosya_adı).Activate
Sheets("LİSTE").Range("A1:I74").Copy

Windows(yeni_dosya_adı).Activate
Range("A1").Select
    
ActiveSheet.Paste
Range("A1").Select

'ilave
Windows(dosya_adı).Activate
Sheets("ÇIKIŞ").Range("A1:J61").Copy

Windows(yeni_dosya_adı).Activate
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = "ÇIKIŞ"
Range("A1").Select
    
ActiveSheet.Paste
Range("A1").Select
Cells.Replace "[" & dosya_adı & "]", ""
'----------------------

Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Windows(dosya_adı).Activate
ActiveWindow.WindowState = xlMaximized
MsgBox "YEDEKLENDİ"

End Sub

 

[1Al2Ver]

Sayın Ömer merhaba,

Çözümünüz ile ; Hem sorunum çözüldü, hem de öğrenmiş oldum,

Çok ama çok teşekkür ederim,

Saygılarımla.

 

[Korhan Ayhan]

Alternatif,

Option Explicit

Sub Yedekle()
    Dim Klasor As String, Dosya_Adi As String
    
    On Error GoTo Son
    
    If Sheets("LİSTE").Range("H1").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        Exit Sub
    End If
    
    Dosya_Adi = Sheets("LİSTE").Range("H1").Value & ".xlsm"
    
    Klasor = "C:\LİSTE_YEDEKLERİ\"
    If Dir(Klasor, vbDirectory) = "" Then MkDir Klasor
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets(Array("LİSTE", "ÇIKIŞ")).Copy
    
    With ActiveWorkbook
        .Sheets("LİSTE").Range("J:XFD").EntireColumn.Delete
        .Sheets("ÇIKIŞ").Range("K:XFD").EntireColumn.Delete
        .SaveAs Klasor & Dosya_Adi, 52
        .Close
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Yedekleme işlemi tamamlanmıştır.", vbInformation
    Exit Sub

Son:
    ActiveWorkbook.Close 0
    MsgBox "Bir hata oluştu!" & vbCr & vbCr & "Dosya açık olabilir!", vbCritical
End Sub

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Alternatif kod ve emekleriniz için çok teşekkür ederim.

Saygılarımla.