Snasui Excel Forum

Code: Select all

Option Explicit

Function FolderExist(Path As String) As Boolean
    On Error Resume Next
    If Not Dir(Path, vbDirectory) = vbNullString Then
        FolderExist = True
    End If
    On Error GoTo 0
End Function

Sub BUandSave2()

Dim MyDate
Dim MyTime
Dim TestStr As String
Dim Test1Str As String
Dim Newfolder As String
Dim backupfile As String

MyDate = Date    ' MyDate contains the current system date.
MyTime = Time    ' Return current system time.
TestStr = Format(MyTime, "hh.mm.ss")
Test1Str = Format(MyDate, "DD-MM-YYYY")

backupfile = Test1Str & " " & TestStr & " " & ActiveWorkbook.Name

Newfolder = ActiveWorkbook.Path & "\Backup_Test"

If FolderExist(Newfolder) Then
	MsgBox "Exist folder " & Newfolder
	ChDir Newfolder
	ThisWorkbook.SaveAs backupfile
	ActiveWorkbook.Save
	Application.DisplayAlerts = True

	Else
		MsgBox "Not exist folder " & Newfolder
		MkDir Newfolder
		ChDir Newfolder
		ThisWorkbook.SaveAs backupfile
		ActiveWorkbook.Save
		Application.DisplayAlerts = True
End If
End Sub

Code: Select all

Option Explicit

Function FolderExist(Path As String) As Boolean
    On Error Resume Next
    If Not Dir(Path, vbDirectory) = vbNullString Then
        FolderExist = True
    End If
    On Error GoTo 0
End Function

Sub BUandSave()
Dim MyDate As Date, MyTime As Date
Dim TestStr As String, Test1Str As String
Dim Newfolder As String, backupfile As String
Dim CurFd As String

CurFd = "D:\Test_File"
MyDate = Date    ' MyDate contains the current system date.
MyTime = Time    ' Return current system time.
TestStr = Format(MyTime, "hh.mm.ss")
Test1Str = Format(MyDate, "DD-MM-YYYY")

backupfile = Test1Str & " " & TestStr & " " & "TestCopyNewFile.xls"

Newfolder = CurFd & "\Backup_Test"
ChDir CurFd
If FolderExist(Newfolder) Then
    MsgBox "Exist folder " & Newfolder
    ChDir Newfolder
    ThisWorkbook.SaveAs backupfile
Else
    MsgBox "Not exist folder " & Newfolder
    MkDir Newfolder
    ChDir Newfolder
    ThisWorkbook.SaveAs backupfile
End If
End Sub