Tự động lưu file ra một folder khác + (1 người xem)

[nguyendinhtutw]

Dear các anh,
Em nhờ các anh giúp em một code VBA để tự động lưu file ra một folder khác khi đóng file, và:
1, Trong cùng một ngày, file lưu sẽ bị ghi đè (overwrite) sau mỗi lần đóng file.
2, Sang ngày khác, các file lưu của ngày hôm trước sẽ không bị ghi đè bởi file lưu của ngày hôm sau.
Mong nhận được trợ giúp của các anh GPE, em cảm ơn các anh.
Trân trọng,

 

[giaiphap]

Dear các anh,
Em nhờ các anh giúp em một code VBA để tự động lưu file ra một folder khác khi đóng file, và:
1, Trong cùng một ngày, file lưu sẽ bị ghi đè (overwrite) sau mỗi lần đóng file.
2, Sang ngày khác, các file lưu của ngày hôm trước sẽ không bị ghi đè bởi file lưu của ngày hôm sau.
Mong nhận được trợ giúp của các anh GPE, em cảm ơn các anh.
Trân trọng,

Bạn dùng thử code này xem sao.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="D:\" & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
        :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
End Sub

 

[nguyendinhtutw]

Bạn dùng thử code này xem sao.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="D:\" & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
        :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
End Sub

Cảm ơn anh, code của anh chạy ngon rồi ạ
Anh cho em hỏi thêm, nếu như folder lưu file chưa có sẵn, thì code sẽ như thế nào để sẽ tự tạo ra folder trước khi lưu ạ?

 

[Kiều Mạnh]

cẩn thận nếu lỡ tay xóa hết dữ liệu đi khi đóng file thì cả 2 file tèo téo teo ................... trắng tinh

 

[giaiphap]

Cảm ơn anh, code của anh chạy ngon rồi ạ
Anh cho em hỏi thêm, nếu như folder lưu file chưa có sẵn, thì code sẽ như thế nào để sẽ tự tạo ra folder trước khi lưu ạ?

Thêm code sau vào Module.

Sub MakeAllPath(ByVal PS$)
    Dim PP$
    If PS <> "" Then
        PP = Left(PS, InStrRev(PS, "\") - 1)
        If Dir(PP, vbDirectory) = "" Then
            MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
            If Right(PP, 1) <> ":" Then MkDir PP
        End If
    End If
End Sub

Sau đó sửa code

Workbook_BeforeClose

như sau:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim s As String
Application.DisplayAlerts = False
s = "D:\A\B\C\": MakeAllPath s
ActiveWorkbook.SaveAs Filename:=s & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
        :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
End Sub

 

[ndu96081631]

Thêm code sau vào Module.

Sub MakeAllPath(ByVal PS$)
    Dim PP$
    If PS <> "" Then
        PP = Left(PS, InStrRev(PS, "\") - 1)
        If Dir(PP, vbDirectory) = "" Then
            MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
            If Right(PP, 1) <> ":" Then MkDir PP
        End If
    End If
End Sub

Sau đó sửa code

Workbook_BeforeClose

như sau:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim s As String
Application.DisplayAlerts = False
s = "D:\A\B\C\": MakeAllPath s
ActiveWorkbook.SaveAs Filename:=s & Format(Now(), "DD-MM-YYYY") & ".xlsm", FileFormat _
        :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
End Sub

Đã nhiều lần được đề cập trên GPE rằng: Hàm Dir và MkDir của VB sẽ không có tác dụng nếu đường dẫn có chứa chuỗi tiếng Việt có dấu
Nên dùng Scripting.FileSystemObject để làm điều này. Hoặc dùng MkDir trên DOS là hoàn hảo nhất