Yedekleme Makrosu

[bluefalcon]

Arkadaşlar merhaba,

Aşağıdaki kod ile üzerinde çalışılmakta olan dosyayı farklı kaydederek yedek aldırmaya çalışıyorum. Öncelikli olarak C:\ altında bir klasörün olup olmadığı denetleniyor eğer yoksa yaratılıyor. Sonrasında yedekleme yapılacak olan dosya türü seçilerek yedek dosyası oluşturuluyor. Sorun şu ki bu aşamaya kadar herşey tamam. Ancak kopyanın oluşturulması maalesef yapılamıyor. Adım adım tüm kodları çalıştırdım ve sorunu bulmaya çalıştım... bulamadım. Hatalı olan yer hususunda yönlendirmelerinizi bekliyorum, şimdiden teşekkürler;


Sub YEDEKLE()
Kayit_Yeri = "C:\YEDEK\"
On Error Resume Next
If Dir(Kayit_Yeri) = "" Then MkDir Kayit_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 = Kayit_Yeri 'Application.DefaultFilePath & "\"
TempFileName = Sourcewb.Name & " " & Format(Now, "dd.mm.yyyy-hh:mm:ss")
With Destwb
.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum, Password:="148264"
.Close SaveChanges:=False
End With
MsgBox "Dosyaniz Asagidaki Isimle Yedeklenmistir." & Chr(10) & TempFileName, vbInformation, "Ajandam Uyary Sistemi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[halit3]

Merhaba kodlarınızı mesaj yazdığınız bölümün üstündeki # bu simgeye tıklayarak CODE] [/CODE arasına yapıştırın.

Formda buna benzer bir sürü örnekler mevcut hataları anlamak için (On Error Resume Next) satırlarını silmeniz gerekir yoksa hataları anlamak zor. Ayrıca tarih ve saat değerlerinde aksanlı harfler kullanmayın.


kod:

Sub YEDEKLE()
Kayit_Yeri = "C:\YEDEK\"
'On Error Resume Next

[COLOR="Red"]If CreateObject("Scripting.FileSystemObject").FolderExists(Kayit_Yeri) = False Then
MkDir Kayit_Yeri
End If[/COLOR]
'If Dir(Kayit_Yeri) = "" Then MkDir Kayit_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 = Kayit_Yeri 'Application.DefaultFilePath & "\"

[COLOR="red"]Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
[/COLOR]
TempFileName = [COLOR="red"]fL.GetBaseName(Sourcewb.Name) & " " & Format(Now, "yyyy-mm-dd hh-nn-ss")[/COLOR]
With Destwb

.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum, Password:="148264"
.Close SaveChanges:=False
End With
MsgBox "Dosyaniz Asagidaki Isimle Yedeklenmistir." & Chr(10) & TempFileName, vbInformation, "Ajandam Uyary Sistemi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub