çalışma kitabını arşive kaydetmek

[önder34]

merhaba arkadaşlar çalışma kitabının iki sayfasını aşağıdaki makro ile kaydedebiliyorum . Şimdi başka bir kitapda birden fazla sayfa var ve ben tüm kitabı dosya adı ay yıl ve dosya adı ile nasıl kaydedebilirim .Kodlarda nerde değişiklik yapabilirim yardımlarınızı bekliyorum

Option Explicit


Sub AutoShape9_Tıklat()
If Not CreateObject("Scripting.FileSystemObject").FolderExists("C:\YEDEK") Then
CreateObject("Scripting.FileSystemObject").CreateFolder ("C:\YEDEK")
End If
Sheets(Array("ekders", "ekders2")).Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\YEDEK\" & ActiveSheet.Name & "_" & Format(Date, "mmmm_yyyy") & ".xls"
ActiveWorkbook.Close
MsgBox "Verileriniz C:\YEDEK Klasörüne Kayıt Edilmiştir.", vbOKOnly + vbInformation, "ÖMER DEMİR"


End Sub

 

[halit3]

Bunu denermisiniz.

Sub çalışmakitablarıyap()
Dim sayfa As Worksheet
For Each sayfa In Worksheets
sayfa.Copy
ActiveWorkbook.SaveAs Filename:="C:\YEDEK\" & sayfa.Name & "_" & Format(Now, " dd_mm_yyyy_hh_nn_ss")
ActiveWorkbook.Close False
Next sayfa
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
End Sub

 

[önder34]

Halit bey yardımınız ve ilginiz için teşekkür ederim . ben işin içinden çıkamadım . kullandığım dosya ve kodlar ekteki dosyam da mevcut burda sadece ekders ve ekders2sayfasını yedekliyor benim istediğim tüm sayfalarıyla olduğu gibi yedeklesin sanırım kodda küçük bir değişiklikle bu mümkündür ama ben yapamadım

 

[halit3]

Halit bey yardımınız ve ilginiz için teşekkür ederim . ben işin içinden çıkamadım . kullandığım dosya ve kodlar ekteki dosyam da mevcut burda sadece ekders ve ekders2sayfasını yedekliyor benim istediğim tüm sayfalarıyla olduğu gibi yedeklesin sanırım kodda küçük bir değişiklikle bu mümkündür ama ben yapamadım

Ekli dosyayı kontrol ediniz.

Sub farklıkayıtet()
ActiveWorkbook.Save
klasor = "C:\YEDEK"
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
yer = Dosya_adi & "_" & Format(Now, " dd_mm_yyyy_hh_nn_ss")
On Error Resume Next
If Dir(klasor) = "" Then MkDir (klasor)
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
DosyaSistemi.CopyFile ThisWorkbook.FullName, (klasor & "\" & yer) & Uzanti
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
End Sub