Thứ Sáu, 8 tháng 1, 2021

VBA tự động sao lưu dự phòng sổ kế sách kế toán

Sub Luu_Du_Phong()
On Error Resume Next
Application.ScreenUpdating = True
Application.DisplayAlerts = False
File_Path_PC = path_file.Range("b1").Value
File_Path_Lan = path_file.Range("b2").Value
'DUONG DAN THU MUC HIEN HANH - FILE LAM VIEC
FILE_PATH = CurDir
'Ten File Hien hanh
File_Name = ActiveWorkbook.Name
File_Name = Left(File_Name, Len(File_Name) - 5)
'KIEM TRA TEN FILE - TRONG PC
Dim X1 As String
For i = 0 To 999
File_Name_PC = File_Name & Right("000" & i, 3)
X1 = Dir(File_Path_PC & "" & File_Name_PC & ".xlsb")
If X1 = "" Then
File_Name_PC = File_Name & Right("000" & i, 3)
Exit For
End If
Next
'KIEM TRA TEN FILE - TRONG MANG LAN
Dim X2 As String
For i = 0 To 999
File_Name_LAN = File_Name & Right("000" & i, 3)
X2 = Dir(File_Path_PC & "" & File_Name_LAN & ".xlsb")
If X2 = "" Then
File_Name_LAN = File_Name & Right("000" & i, 3)
Exit For
End If
Next
ActiveWorkbook.SaveAs Filename:=File_Path_PC & "" & File_Name_PC & ".xlsb", FileFormat:= _
xlExcel12, CreateBackup:=False
SetAttr File_Path_PC & "" & File_Name_PC & ".xlsb", vbReadOnly
'B LUU TRONG THU MUC DU PHONG - QUA MANG
ActiveWorkbook.SaveAs Filename:=File_Path_Lan & "" & File_Name_LAN & ".xlsb", FileFormat:= _
xlExcel12, CreateBackup:=False
SetAttr File_Path_Lan & "" & File_Name_LAN & ".xlsb", vbReadOnly
End Sub
Previous Post
Next Post

0 nhận xét: