çalışma kitabını yedekleme

[halit3]

Selamlar
aşağıdaki kodu kullanıyorum. bu kod ile ilgili olarak yedekleme yapmak için;
Dosyayı kaydettiğimde otomatik yedek alabilir mi?
teşekkürler
Uygar

Sub AKTİF_DOSYAYI_YEDEKLE()
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.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
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "Ajandam Uyarı Sistemi"
Application.DisplayAlerts = True
End Sub

Dosyayı her kayıt yaptığınızda yedeklemek için aşağıdaki kodu makrolar bölümünde ThisWorkbook sayfası içine koyup deneyiniz.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Dosya As String, Kayıt_Yeri As String, uzanti As String, dosyaadi As String, yer As String
yer = "D:\YEDEK\"
If CreateObject("Scripting.FileSystemObject").FolderExists(yer) = False Then
MkDir yer
End If
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosyaadi = ThisWorkbook.FullName
Dosya = fL.GetBaseName(dosyaadi)
uzanti = "." & fL.GetExtensionName(dosyaadi)
[COLOR=red]ActiveWorkbook.Save[/COLOR]
Application.DisplayAlerts = False
Kayıt_Yeri = yer & Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
fL.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"
Application.DisplayAlerts = True
End Sub

Bir komut düğmesi ile kayıt yapmak isterseniz aşağıdaki kodu kullanabilirsiniz.

Sub AKTİF_DOSYAYI_YEDEKLE()
Dim Dosya As String, Kayıt_Yeri As String, uzanti As String, dosyaadi As String, yer As String
yer = "D:\YEDEK\"
If CreateObject("Scripting.FileSystemObject").FolderExists(yer) = False Then
MkDir yer
End If
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosyaadi = ThisWorkbook.FullName
Dosya = fL.GetBaseName(dosyaadi)
uzanti = "." & fL.GetExtensionName(dosyaadi)
ActiveWorkbook.Save
Application.DisplayAlerts = False
Kayıt_Yeri = yer & Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
fL.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"
Application.DisplayAlerts = True
End Sub

Not : yukarıdaki her iki uygulamada D sürücüsünün içinde YEDEK klasörünün içine kauıt yapıyor eğer YEDEK klasör yoksa D sürücüsünde kendisi bu klasörü oluşturuyor.

 

[uygaroz]

Halit Bey
yardımlarınız için teşekkür ederim.
fakat kayıttan sonra çıkan mesaj
2 kere tekrar ediyor?
sebebini bulamadım
bakma sansınız olabilirmi?
Uygar

 

[halit3]

Halit Bey
yardımlarınız için teşekkür ederim.
fakat kayıttan sonra çıkan mesaj
2 kere tekrar ediyor?
sebebini bulamadım
bakma sansınız olabilirmi?
Uygar

iki kere Mesaj aldığınız kodun içindeki aşağıdaki bölümü silin

ActiveWorkbook.Save

 

[uygaroz]

Halit bey
teşekkürler
Uygar

 

[selimcengizince]

bu kodu denermisiniz.
Sub AKTİF_DOSYAYI_YEDEKLE()
Kayıt_Yeri = "C:\YEDEK\"
On Error Resume Next
If Dir(Kayıt_Yeri) = "" Then MkDir Kayıt_Yeri
On Error Resume Next
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Kayıt_Yeri 'Application.DefaultFilePath & "\"
TempFileName = Sourcewb.Name & " " & Format(Now, "dd_mm_yyyy_hh_mm_ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum, Password:="358100"
.Close SaveChanges:=False
End With
MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & TempFileName, vbInformation, "Ajandam Uyarı Sistemi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Merhabalar,
Bu kodu kullanarak; sayfayı kullanıcıya çaktırmadan yedekleyebiliyorum. Mesaj kutusu kısmını sildim, güzel oldu )

Sormak istediğim;
Aynı makro içerisinde başka bir sayfanın da yedeklenmesini istiyorum. İlgili kısma bu kodları tekrar ekleyince, "Dim FileExtStr As String" satırını göstererek hata veriyor..yardımcı olabilir misiniz?

 

[selimcengizince]

bu sorunu çözdüm fakat bu kodla aldığım yedek uyumluluk denetleyicisini açıyor..sanırım sadece .xls olarak kaydetmem gerekiyor..

Bu kodu, .xls olarak kaydedecek şekilde düzenleyebilmem için yardımınıza ihtiyacım var..dağıldım resmen..benzer olan bütün konuları inceledim, istediğimi buluyorum ama kendi makroma uygulayamıyorum..

 

[halit3]

bu sorunu çözdüm fakat bu kodla aldığım yedek uyumluluk denetleyicisini açıyor..sanırım sadece .xls olarak kaydetmem gerekiyor..

Bu kodu, .xls olarak kaydedecek şekilde düzenleyebilmem için yardımınıza ihtiyacım var..dağıldım resmen..benzer olan bütün konuları inceledim, istediğimi buluyorum ama kendi makroma uygulayamıyorum..

ActiveSheet.Copy

yukarıdaki kodun yerine aşağıdaki kodu kullan kırmızı bölüm sayfa ismini kendince yaz.

  Worksheets([COLOR="Red"]"Sayfa1"[/COLOR]).Copy

.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum, Password:="358100"

yukarıdaki kodun yerine aşağıdaki kodu kullan

.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=[COLOR="red"]4143[/COLOR], Password:="358100"