Autosave excel file every 30 minute

[P1649]

ระหว่างเวลาทำงานแต่ละวัน ต้องการ auto save excel file ตามตัวอย่างที่ลิงค์ โดยไม่รบกวนผู้ใช้งาน ชื่อไฟล์เป็น วัน-เวลา และกำหนดให้ autocave เวลา 10.00am-05.00pm ต้องแก้ไขอย่างไรบ้างครับ

http://www.tarwara.info/blog/automatic- ... 2007-2010/
http://www.mrexcel.com/forum/excel-ques ... sheet.html

ขอบคุณครับ
อมร

[snasui]

ควรแนบไฟล์ที่ลองทำตาม Link แล้วและยังติดปัญหามาด้วย ช่วยแจ้งด้วยว่าติดปัญหาที่บรรทัดใด หรือปัจจุบันผลเป็นเช่นไร ต้องการผลเป็นเช่นไรครับ

[P1649]

(code)
Public Const backupfolder As String = "C:\excelbackup\"
Sub Auto_Save()
If Dir(backupfolder, vbDirectory) = "" Then

' This will check if folder already exist
' If not then it will create new directory at first time

MkDir backupfolder
Call Save

' Save copy of Excel file to backupfolder

Else
Call Save

' If folder already exist then only save copy of Excel File

End If
End Sub
Function Save() As String
' Auto_save Macro
' This will create a copy of file at Seleted destination path
' Keyboard Shortcut: Ctrl+r
' Saves the current file to a backup folder

Dim savedate
savedate = Date ' Current system date
Dim savetime
savetime = Time ' Current system time
Dim formattime As String
formattime = Format(savetime, "hh.mm.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD-MM-YYYY")

Application.DisplayAlerts = False
'
'Application.Run ("Auto_Save")
'
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & formatdate & " " & formattime & " " & ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
MsgBox "Backup Run. Please Check at: " & backupfolder

End Function
(code)

ต้องการให้ auto save ทุกๆ 30 นาที โดยไม่ต้องกด Ctrl+Q และทำงานระหว่างเวลา 10.00am-05.00pm

[snasui]

ช่วยแนบมาเป็นไฟล์ครับ จะได้ช่วยทดสอบได้ นอกจากนี้แล้วการโพสต์ Code ให้แสดงเป็น Code เพื่อสะดวกในการ Copy ไปทดสอบ ดูตัวอย่างได้ที่นี่ครับ http://www.snasui.com/viewtopic.php?f=2&t=1187

[P1649]

Code: Select all

Public Const backupfolder As String = "C:\excelbackup\"
Sub Auto_Save()
If Dir(backupfolder, vbDirectory) = "" Then

' This will check if folder already exist
' If not then it will create new directory at first time

MkDir backupfolder
Call Save

' Save copy of Excel file to backupfolder

Else
Call Save

' If folder already exist then only save copy of Excel File

End If
End Sub
Function Save() As String
' Auto_save Macro
' This will create a copy of file at Seleted  destination path
' Keyboard Shortcut: Ctrl+r
' Saves the current file to a backup folder

Dim savedate
savedate = Date    ' Current system date
Dim savetime
savetime = Time    ' Current system time
Dim formattime As String
formattime = Format(savetime, "hh.mm.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD-MM-YYYY")

Application.DisplayAlerts = False
'
'Application.Run ("Auto_Save")
'
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & formatdate & " " & formattime & " " & ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
Beep
MsgBox "Backup Run. Please Check at: " & backupfolder

End Function

ต้องการให้ auto save ทุกๆ 30 นาที โดยไม่ต้องกด Ctrl+Q และทำงานระหว่างเวลา 10.00am-05.00pm

[snasui]

ไฟล์แนบที่มี Macro ควรเป็น .xlsm ไม่ใช่ .xlsx ครับ

ไฟล์ที่ส่งมาถามควรแนบ Code มาให้เรียบร้อยแล้วครับ

[tupthai]

http://www.it-guides.com/training-a-tut ... excel-2007
http://support.microsoft.com/kb/289273/th

[P1649]

เนื่องจากต้องการข้อมูลที่บันทึกทุกๆ 30 นาทีมาประมวลผล จึงไม่สามารถใช้คำสั่ง autosave/recovery ปกติได้
ไฟล์ทดสอบตามเอกสารแนบ ความต้องการเพิ่มเติมคือ
1. Autosave every 30 minute โดยไม่ต้องกด Ctrl+Q
2. Start 10.00am Finish 05.00pm

ขอบคุณครับ

Code: Select all

Public Const backupfolder As String = "C:\excelbackup\"
Sub Auto_Save()
If Dir(backupfolder, vbDirectory) = "" Then

' This will check if folder already exist
' If not then it will create new directory at first time

MkDir backupfolder
Call Save

' Save copy of Excel file to backupfolder

Else
Call Save

' If folder already exist then only save copy of Excel File

End If
End Sub
Function Save() As String
' Auto_save Macro
' This will create a copy of file at Seleted  destination path
' Keyboard Shortcut: Ctrl+r
' Saves the current file to a backup folder

Dim savedate
savedate = Date    ' Current system date
Dim savetime
savetime = Time    ' Current system time
Dim formattime As String
formattime = Format(savetime, "hh.mm.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD-MM-YYYY")

Application.DisplayAlerts = False
'
'Application.Run ("Auto_Save")
'
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & formatdate & " " & formattime & " " & ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
Beep
End Function

[snasui]

ไม่พบ Code ในไฟล์แนบครับ

[P1649]

ตัวอย่าง

[snasui]

Code ที่ Copy มาวางไม่ได้เป็น Statement ของ VBA

บรรทัดใดที่แสดงเป็นสีแดงแสดงว่าเป็นบรรทัดที่ Error จำเป็นต้องแก้ไขให้ไม่เป็นสีแดงก่อนครับ

ผู้ที่เคยเขียน VBA ควรทราบว่า Comment ของ VBA มีลักษณะอย่างไร ควรมีเครื่องหมายใดนำหน้า และตัวอักษรเป็นสีใด กรณีที่คุณ P1649 ไม่เคยเขียน VBA ผมแนะนำว่ายังไม่ควรใช้ VBA เพราะเมื่อผู้ตอบได้ตอบไปคุณก็ปรับใช้เองไม่เป็นอยู่ดีแม้การปรับนั้นเป็นแค่เล็ก ๆ น้อย ๆ

ถ้าจำเป็นต้องใช้ ให้ผู้ที่เขียนเป็นเขียนให้ ติดตรงไหนค่อยถามกัน สำหรับฟอรัมถามตอบนี้ผู้ที่ถามเกี่ยวกับ VBA จำเป็นจะต้องมีความรู้เกียวกับ VBA มาบ้าง ต้องเขียนมาเองก่อนแล้วถามเฉพาะที่ติดปัญหาไม่ใช่ไม่เคยเขียนเลยครับ

[P1649]

ขอบคุณที่เป็นแรงบันดาลให้เรียนรู้ โค้ดข้างล่างให้งานได้แล้วครับ แต่อยากขอคำแนะนำเพิ่มเติม เรื่องการเขียน ต้องตั้งตัวแปร หรือแก้ไขอย่างไรให้กระชับ เหมาะสมกว่านี้ครับ
Final : Auto Save AS every 30 minutes with NO warning upon saving over the last copy.
__________
ThisWorkBook

Code: Select all

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnTime nTime, "SaveFile", , False
End Sub
Private Sub Workbook_Open()
Call SaveFile
End Sub

__________
Module1

Code: Select all

Public Const backupfolder As String = "D:\SETbackup\"
Public nTime As Double
Public Sub SaveFile()
With ThisWorkbook
nTime = Now + TimeSerial(0, 1, 0)  'every minute
If Dir(backupfolder, vbDirectory) = "" Then
MkDir backupfolder
.SaveCopyAs Filename:=backupfolder & (Format(Now, " yyyy-mm-dd, hh.mm.ss ")) & ActiveWorkbook.Name
Application.OnTime nTime, "SaveFile"
Else
.SaveCopyAs Filename:=backupfolder & (Format(Now, " yyyy-mm-dd, hh.mm.ss ")) & ActiveWorkbook.Name
Application.OnTime nTime, "SaveFile"
End If
End With
End Sub

[snasui]

Code นี้มีไม่กี่บรรทัด ตัวแปรก็ได้ประกาศไว้เรียบร้อยแล้ว ไม่ทราบว่าติดปัญหาใดครับ ถ้าไม่มีปัญหาไม่จำเป็นต้องปรับครับ

[snasui]

แนวทางในการปรับ สามารถลด Code ในส่วนของ If Statement ลงได้ ลองดูตัวอย่างด้านล่างครับ

Code: Select all

Public Const backupfolder As String = "D:\SETbackup\"
Public nTime As Double

Public Sub SaveFile()
    With ThisWorkbook
        nTime = Now + TimeSerial(0, 1, 0)  'every minute
        If Dir(backupfolder, vbDirectory) = "" Then
            MkDir backupfolder
        End If
        .SaveCopyAs Filename:=backupfolder & (Format(Now, _
            " yyyy-mm-dd, hh.mm.ss ")) & ActiveWorkbook.Name
        Application.OnTime nTime, "SaveFile"
    End With
End Sub