Excel sayfalarını kitap olarak kayıt yapacak kod

[simetri.]

Merhabalar, değerli forum sakinleri.

Aşağıdaki kod için yardımlarınızı bekliyorum lüfen.

Kod: Çalıştırıldığı kitaptaki tüm sayfaları

"C:\Günlük Yedek" yoluna kitap olarak kaydedecek.

(kitabın VBAProject kısmı dahil)

 

[muygun]

sayfaları istenilen yere istenilen isimle kaydet-sil

Merhaba;
Eki inceleyin. Tam otomasyon olmasada Size fikir verecektir.
İyi çalışmalar.

Not: Kodlar Syn. halit3'ün çalışmasından alıntıdır.

 

[simetri.]

Merhaba sayın muygun.

Çok da uğraşmışsınız. Teşekkür ederim. Lakin benim istediğim kod bu değil.

Kod şu şekilde olacak:

xx adlı kitapta Sayfa1 Sayfa2 Sayfa3 şeklinde 3 sayfa var.

Kodu herhangi bir yerde tetiklediğimiz zaman.

( C sürücüsündeki Günlük Yedek klasösürün içinde )

Sayfa1 Sayfa2 Sayfa3 adında 3 tane kitap oluşacak.

xx adlı kitaptaki makro kodlarıda yeni oluşacak kitaba aktarılacak.

Yazdıklarımın haricinde silme vs başka birşey olmayacak.

İnşallah anlaşılır olmuştur.

 

[halit3]

Alternatif kod:

Sub SAYFALARI_YEDEKLE()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Set fLk = CreateObject("Scripting.FileSystemObject")
uzanti = fLk.GetExtensionName(ActiveWorkbook.Name) ' uzantı buluyor

Klasor = "C:\Günlük Yedek"
If fLk.FolderExists(Klasor) = False Then
MkDir Klasor
End If
ActiveWorkbook.Save

For i = 1 To ThisWorkbook.Sheets.Count
sayfa_adi = Sheets(i).Name
Dosya_adi = sayfa_adi & " " & Format(Now, "dd_mm_yyyy_hh_nn_ss")
Kayıt_Yeri = Klasor & "\" & Dosya_adi & "." & uzanti
fLk.CopyFile ThisWorkbook.FullName, Kayıt_Yeri

Dim WB As Workbook
Set WB = Workbooks.Open(Kayıt_Yeri)

For j = ActiveWorkbook.Sheets.Count To 1 Step -1
If sayfa_adi <> Sheets(j).Name Then
Worksheets(j).Delete
End If
Next

ActiveWorkbook.Save
ActiveWorkbook.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "işlem tamam"

End Sub

 

[simetri.]

Teşekkür ederim

Sayın Halit3 Hocam

Ellerinize sağlık.