Code VBA Excel Tự Động Lưu Và Tạo Một Bản Sao Chép Vào Thư Mục Khác

Bài viết dưới đây bởi tác giả blogdaytinhoc.com. Bài viết chi tiết dể hiểu, hy vọng có ích với bạn đọc.

Với Excel, mất điện đột ngột, lỗi File, mặc dù trước đó bạn đã bấm lưu, nhưng khi mở ra dữ liệu vẫn có thể bị mất hoặc thậm tệ hơn là mất điện quá lâu và dữ liệu cũng không lưu.

Để giải quyết vấn đề sao lưu tự động bằng VBA, và bạn luôn tự tin File Excel luôn được lưu và được sao chép vào một thư mục lưu trữ quy định trong ổ đĩa, ở đây mình quy định Folder lưu trữ là "Backup", và nó tự động được tạo ra nếu không có sẵn trong ổ đĩa của bạn, còn nếu có sẵn nó sẽ tự biết Copy một bản dự phòng vào đó.

Chúng ta thực hiện các bước sau:

1

Mở File bạn cần lưu tự động và thực hiện như sau

Mở cửa sổ soạn thảo Code ra, Nhấn ALT+F11 hoặc Developer, bấm chọn VisualBasic hoặc Viewcode để thực hiện viết code, bạn nào chưa biết cách làm tham khảo bài "VBA Cơ Bản Bài 01"

2

Viết code cho sự kiện WorkbookOpen, gọi Code AutoBackup

Nháy đúp vào 'ThisWorkbook', bên phải chọn sự kiện Open nhé, như hình trên, một Private Sub cho sự kiện Open sẽ tự động sinh ra, bạn chỉ cần chép đoạn code này vào

Private Sub Workbook_Open()

    Application.OnTime Now + TimeValue("00:00:20"), "AutoBackup"

End Sub

3

Viết code cho Sub AutoBackup tại Module "mdAutoBackup"

Nhập đúp chuột vào Module "mdAutoBackup", và copy đoạn code sau dán vào trình soạn thảo VBA của Excel (Nhấn phím Alt + F11 trong màn hình làm việc của Excel).

Option Explicit

Sub AutoBackup()

    Dim FileExtStr  As String

    Dim FileFormatNum As Long

    Dim xWs         As Worksheet

    Dim xWb         As Workbook

    Dim FSO         As Object

    Dim MyPath      As String

    

    Application.ThisWorkbook.Save

    MyPath = ThisWorkbook.Path & "\Backup"        '<< Duong dan thu muc Import

    

    If Right(MyPath, 1) = "\" Then

        MyPath = Left(MyPath, Len(MyPath) - 1)

    End If

    

    Set FSO = CreateObject("scripting.filesystemobject")

    

    If FSO.FolderExists(MyPath) = FALSE Then

        MsgBox "Duong dan " & MyPath & "Thu muc Backup duoc tao!", vbInformation

        Dim FolderName As String

        Application.ScreenUpdating = FALSE

        Set xWb = Application.ThisWorkbook

        FolderName = xWb.Path & "\" & "Backup"        '& DateString

        MkDir FolderName

        MsgBox "File cua ban se duoc luu tai " & MyPath, vbInformation

        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _

                                Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "(" & _

                                Right(Timer, 1) & ")" & Format(Date, "dd.mm.yyyy") & ".xlsm"

    Else

        MsgBox "File cua ban se duoc luu tai " & MyPath, vbInformation

        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _

                                Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "(" & _

                                Right(Timer, 1) & ")" & Format(Date, "dd.mm.yyyy") & ".xlsm"

    End If

    Application.OnTime Now + TimeValue("00:00:20"), "AutoBackup"

End Sub

Tại dòng code cuối cùng , mình đang để chế độ tự động lưu và Backup sau 20s, các bạn thay thế tùy ý nhé

nhatthienkt xin góp ý thêm:

- Nếu bạn muốn lưu với file định dạng .xlsb thì thay vào phần màu đỏ.

- Thay đổi thời gian tự động sao lưu thì chỉnh chỗ TimeValue("00:00:20")