Yedek alma kodunda değişiklik

[S.Yiğit]

Merhabalar,

Aşağıdaki kod ile her farklı kaydettiğimde ve kaydettiğimde masa üstümde bulunan yedekler klasörüne yedek alıyorum. Şimdi başka bir çalışma için bu kod değiştirmem lazım. Butona bağlayıp sadece butona tıkladığımda yedek almalı. Birde bu dosya ortak ağda bulunuyor. Benden başkalarıda kullanacak. Diğer kullanıcılar yedek almak istediklerinde dosya yolu olmadığı için hata verecek. Böyle bir durumda bir uyarı olabilir mi? Örnek: "Yedek almak istiyorsanız farkı kaydederek alınız lütfen" gibi.. Örnek dosyam ektedir.

Yardımcı olacak arkadaşlara şimdiden teşekkürler

ThisWorkbook:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
Dim d() As String, dosya As String, dosyaAdı As String, uzantı As String
 
With ActiveWorkbook
    d = Split(.Name, ".")
    uzantı = d(UBound(d))
    dosyaAdı = Left(.Name, Len(.Name) - Len(uzantı) - 1)
 
    dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
        "\Yedekler" & Application.PathSeparator & _
        dosyaAdı & Format(Now, " dd.mm.yyyy_hh/mm") & "." & uzantı
 
    .SaveCopyAs Filename:=dosya
End With
 
End Sub

 

[Ömer]

Merhaba,

Kodu ThisWorbook dan silip module kopyalarak butona bağlayınız.

Sub YedekAl()
 
Dim d() As String, dosya As String, dosyaAdı As String, uzantı As String
 
On Error GoTo mesaj
With ActiveWorkbook
    d = Split(.Name, ".")
    uzantı = d(UBound(d))
    dosyaAdı = Left(.Name, Len(.Name) - Len(uzantı) - 1)
 
    dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
        "\Yedekler" & Application.PathSeparator & _
        dosyaAdı & Format(Now, " dd.mm.yyyy_hh/mm") & "." & uzantı
 
    .SaveCopyAs Filename:=dosya
End With
 
Exit Sub
mesaj:
MsgBox "Yedek almak istiyorsanız farkı kaydederek alınız."
 
End Sub

.

 

[S.Yiğit]

Hocam merhaba,

Gayet güzel çalışıyor. Teşekkür ederim, elinize sağlık.