Tạo thêm file backup cho file đang làm việc

[pham ha 94]

Nhờ các bác giúp mình hàm VBA.
Quy trình mình thực hiện:
B1: Người sử dụng (NSD) lấy file gốc từ 1 ổ chung cho user
B2: NSD nhập các nội dung vào file và lưu vào ổ riêng tại máy tính cơ quan (theo tên họ mong muốn)
Mong muốn: tại bước 2, khi NSD lưu file này thì mình muốn tạo 1 file save as tại ổ chung để backup dữ liệu đó và file mới có tên dưới định dạng: Lấy dữ liệu tại sheet1 ô A1_A2_(time lưu file)_(ngày lưu file). đuôi file
P/s do hệ thống nội bộ chặn cài đặt các app và internet, chỉ dùng được mạng LAN nên mình chỉ hi vọng duy nhất VBA có thể giúp đỡ được
Nhờ các bác giúp mình với

 

[HUONGHCKT]

Nhờ các bác giúp mình hàm VBA.
Quy trình mình thực hiện:
B1: Người sử dụng (NSD) lấy file gốc từ 1 ổ chung cho user
B2: NSD nhập các nội dung vào file và lưu vào ổ riêng tại máy tính cơ quan (theo tên họ mong muốn)
Mong muốn: tại bước 2, khi NSD lưu file này thì mình muốn tạo 1 file save as tại ổ chung để backup dữ liệu đó và file mới có tên dưới định dạng: Lấy dữ liệu tại sheet1 ô A1_A2_(time lưu file)_(ngày lưu file). đuôi file
P/s do hệ thống nội bộ chặn cài đặt các app và internet, chỉ dùng được mạng LAN nên mình chỉ hi vọng duy nhất VBA có thể giúp đỡ được
Nhờ các bác giúp mình với

Bạn tham khảo đoạn code này:
Sau khi chạy Sub AutoBackup dưới đây: 1 folder có tên Backup sẽ được tạo ra (nếu chưa có)và file chứa code này sẽ được SaveAs thành 1 bản nữa có tên là "Expiry" và ngày tháng năm hiện tại. Nếu đã có file "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm" rồi thì ghi đè.

Option Explicit

Sub AutoBackup()
    Dim xWb         As Workbook, fso         As Object
    Dim MyPath      As String, FolderName As String
    Dim Ws As Worksheet
     Application.ScreenUpdating = False
     Application.ThisWorkbook.Save
        MyPath = ThisWorkbook.Path & "\Backup"
    If Right(MyPath, 1) = "\" Then
        MyPath = Left(MyPath, Len(MyPath) - 1)
    End If
        Set fso = CreateObject("scripting.filesystemobject")
    If fso.FolderExists(MyPath) = False Then
    Set xWb = Application.ThisWorkbook
        FolderName = xWb.Path & "\" & "Backup"
        MkDir FolderName
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _
                                "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm"
    Else
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _
                                 "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm"
    End If
    Set fso = Nothing
Application.ScreenUpdating = True
 End Sub

Hy vọng đúng ý tưởng của bạn.

 

[barney1]

Bạn tham khảo đoạn code này:
Sau khi chạy Sub AutoBackup dưới đây: 1 folder có tên Backup sẽ được tạo ra (nếu chưa có)và file chứa code này sẽ được SaveAs thành 1 bản nữa có tên là "Expiry" và ngày tháng năm hiện tại. Nếu đã có file "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm" rồi thì ghi đè.

Option Explicit

Sub AutoBackup()
    Dim xWb         As Workbook, fso         As Object
    Dim MyPath      As String, FolderName As String
    Dim Ws As Worksheet
     Application.ScreenUpdating = False
     Application.ThisWorkbook.Save
        MyPath = ThisWorkbook.Path & "\Backup"
    If Right(MyPath, 1) = "\" Then
        MyPath = Left(MyPath, Len(MyPath) - 1)
    End If
        Set fso = CreateObject("scripting.filesystemobject")
    If fso.FolderExists(MyPath) = False Then
    Set xWb = Application.ThisWorkbook
        FolderName = xWb.Path & "\" & "Backup"
        MkDir FolderName
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _
                                "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm"
    Else
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _
                                 "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm"
    End If
    Set fso = Nothing
Application.ScreenUpdating = True
 End Sub

Hy vọng đúng ý tưởng của bạn.

Dạ bác, hình như em thấy chưa có đoạn này trong code ạ

 

[HUONGHCKT]

Dạ bác, hình như em thấy chưa có đoạn này trong code ạ
View attachment 288713

ngày tạo file được lấy qua hàm date (trong code có ...& Format(Date, "dd.mm.yyyy")....Còn giờ thì không.
Chủ thớt không đưa file giả định lên thì muốn người khác đoán mò để code cho đúng à?Tôi cũng chỉ là một dạng thầy bói xem voi trong mắt của nhiều người mà. Bạn có thấy câu đầu là "Bạn tham khảo đoạn code này"; và câu cuối "Hy vọng đúng ý tưởng của bạn" không?
Tôi thì tôi vẫn tin là bạn chủ thớt này biết code và làm được điều mình muốn. Hy vọng lần nữa là mình đoán đúng.

 

[pham ha 94]

Bạn tham khảo đoạn code này:
Sau khi chạy Sub AutoBackup dưới đây: 1 folder có tên Backup sẽ được tạo ra (nếu chưa có)và file chứa code này sẽ được SaveAs thành 1 bản nữa có tên là "Expiry" và ngày tháng năm hiện tại. Nếu đã có file "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm" rồi thì ghi đè.

Option Explicit

Sub AutoBackup()
    Dim xWb         As Workbook, fso         As Object
    Dim MyPath      As String, FolderName As String
    Dim Ws As Worksheet
     Application.ScreenUpdating = False
     Application.ThisWorkbook.Save
        MyPath = ThisWorkbook.Path & "\Backup"
    If Right(MyPath, 1) = "\" Then
        MyPath = Left(MyPath, Len(MyPath) - 1)
    End If
        Set fso = CreateObject("scripting.filesystemobject")
    If fso.FolderExists(MyPath) = False Then
    Set xWb = Application.ThisWorkbook
        FolderName = xWb.Path & "\" & "Backup"
        MkDir FolderName
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _
                                "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm"
    Else
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\Backup\" & _
                                 "Expiry " & Format(Date, "dd.mm.yyyy") & ".xlsm"
    End If
    Set fso = Nothing
Application.ScreenUpdating = True
 End Sub

Hy vọng đúng ý tưởng của bạn.

Cảm ơn bạn rất nhiều, mình làm được rồi,Chỉnh lại code 1 chút là được

 

[barney1]

Cảm ơn bạn rất nhiều, mình làm được rồi,Chỉnh lại code 1 chút là được

Chỉnh như thế nào, bạn chia sẻ file mọi người tham khảo đc k?

 

[pham ha 94]

Chỉnh như thế nào, bạn chia sẻ file mọi người tham khảo đc k?

Bạn chỉnh sửa theo nhu cầu sử dung thôi ý. chứ code ổn rồi mà