کمک در بکاب گیری خودکار هنگام خروج

[beheshty]

سلام دوستان
من از ماکروی زیر برای بکاپ گیری استفاده میکنم حالا چه طور میتوانم این ماکرو طوری تغیر بدم که هنگام خروج با طور اتوماتیک بکاب بگیره یا اینکه در ساعتی مشخص از روز بکاب بگیره

  Dim s, M, h, t, yyyy, mm, dd, file As String
    Dim Zaman
    Dim Fn
Public Sub SaveFaileNow()
     
     Call Addres
         

     Fn = Application.GetSaveAsFilename(Zaman)
     ActiveWorkbook.SaveCopyAs Filename:=Fn & ".xlsm"

End Sub

Public Sub Addres()
    file = ActiveWorkbook.Path
    s = Second(Time)
    M = Minute(Time)
    h = Hour(Time)
    t = J_normdate(J_TODAY(1))
    l = Left(t, 4)
    r = Right(t, 2)
    M = Mid(t, 5, 2)
    t = l & "," & M & "," & r
    yyyy = Year(Now)
    mm = Month(Now)
    dd = day(Now)
    If Len(mm) = 1 Then mm = "0" & mm
    If Len(dd) = 1 Then dd = "0" & dd
    If Len(h) = 1 Then h = "0" & h
    If Len(M) = 1 Then M = "0" & M
    If Len(s) = 1 Then s = "0" & s
    
     Zaman = "BACKUP" & t & " - " & (h) & "," & (M) & "," & (s)
End Sub

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[iranweld]

با سلام

کدهای ذیل را در قسمت this workbook کپی نمایید

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Application.DisplayAlerts = False

Dim s, m, h, t, yyyy, mm, dd, file As String

    Dim Zaman
    Dim Fn
     
      file = ActiveWorkbook.Path
    s = Second(Time)
    m = Minute(Time)
    h = Hour(Time)
    t = J_NORMDATE(J_TODAY(1))
    l = Left(t, 4)
    r = Right(t, 2)
    m = Mid(t, 5, 2)
    t = l & "," & m & "," & r
    yyyy = Year(Now)
    mm = Month(Now)
    dd = day(Now)
    If Len(mm) = 1 Then mm = "0" & mm
    If Len(dd) = 1 Then dd = "0" & dd
    If Len(h) = 1 Then h = "0" & h
    If Len(m) = 1 Then m = "0" & m
    If Len(s) = 1 Then s = "0" & s
    
     Zaman = "BACKUP" & t & " - " & (h) & "," & (m) & "," & (s)
     
      ActiveWorkbook.Save
            
  ActiveWorkbook.SaveCopyAs Filename:=file & "\" & Zaman & ".xlsm"
     
     Application.DisplayAlerts = True

End Sub 

[beheshty]

ممنون عالی بود
من backup را به قسمت ادرس اضافه کردم اما وقتی پوشه ای به نام backup موجود نباشه خطا میده
فقط چه کدی باید اضافه بشه که اگه پوشه موجود نبود خودش یه پوشه بسازه و فایل بکاپ بریزه داخل اون

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Application.DisplayAlerts = False

Dim s, m, h, t, yyyy, mm, dd, file As String

    Dim Zaman
    Dim Fn
     
      file = ActiveWorkbook.Path
    s = Second(Time)
    m = Minute(Time)
    h = Hour(Time)
    t = J_NORMDATE(J_TODAY(1))
    l = Left(t, 4)
    r = Right(t, 2)
    m = Mid(t, 5, 2)
    t = l & "," & m & "," & r
    yyyy = Year(Now)
    mm = Month(Now)
    dd = day(Now)
    If Len(mm) = 1 Then mm = "0" & mm
    If Len(dd) = 1 Then dd = "0" & dd
    If Len(h) = 1 Then h = "0" & h
    If Len(m) = 1 Then m = "0" & m
    If Len(s) = 1 Then s = "0" & s
    
     Zaman = "BACKUP" & t & " - " & (h) & "," & (m) & "," & (s)
     
      ActiveWorkbook.Save
            
  ActiveWorkbook.SaveCopyAs Filename:=file & "\backup\" & Zaman & ".xlsm"
     
     Application.DisplayAlerts = True

End Sub