Create txt Backup

[Stromma]

Hi All!

I'm trying to help my wife to create a simple Workbook Backup. This backup must save all data to the Floppy Drive. Her Workbook contains 4 different sheets: Data, Article, Contacts & Information. Sheets Data is between 2.5 to 3 Mb and because of this i save all sheets separetly as txt. In txt format sheets Data changes between 1 to 1.2 Mb (Floppy Disc 1), the other 3 can be saved to the same disc (Floppy Disc 2).

This is what i'm trying to do... :

Create a hardrive temp folder C:\New Backup.

Copy each sheet separetly to a new book and save in C:\New Backup as txt.

Ask for disc 1.

Copy sheets Data.txt from C:\New Backup to Disc 1.

Ask for Disc 2.

Copy sheets Article, Contacts & Information from C:\New Backup to Disc 2.

Delete all files in C:\New Backup.

Delete folder C:\New Backup.

Everything works as i want it to, but just to be on the safe side, since i'm not very good on VBA, i thought i might ask some experts to have a look at it.

I know it's quit much code, but any comment or suggestion will be highly appreciated.

Here's what i come up with so far:

Sub Create_Backup()
Dim fsoObj As Scripting.FileSystemObject, Fs As Object
Dim strPath As String, strFileMask As String, f As String, stKallFil As String
Set fsoObj = New Scripting.FileSystemObject
Set Fs = CreateObject("Scripting.FileSystemObject")
If MsgBox(strExcelApp & "Do you want to create a Backup?", vbYesNo + vbQuestion) = vbNo Then
    Exit Sub
End If
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'Check Drive C And Create Temp Folder New Backup
With fsoObj
    If .Drives("C:").IsReady = True Then
        If .FolderExists("C:\New Backup\") Then
            MsgBox "Folder C:\New Backup allready exists!", vbInformation
        Else
            .CreateFolder ("C:\New Backup")
            MsgBox "Folder C:\New Backup was successfully created!", vbInformation
        End If
    End If
End With
'Copy Sheets Data And Save As Data.txt To C:\New Backup
With fsoObj
    If .Drives("C:").IsReady = True Then
        Sheets("Data").Select
        Sheets("Data").Copy
        ActiveWorkbook.SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False
        ActiveWindow.Close
        MsgBox "Sheets Data was successfully copied to C:\New Backup\Data.txt!", vbInformation
    End If
End With
'Copy Sheets Article And Save As Article.txt To C:\New Backup
With fsoObj
    If .Drives("C:").IsReady = True Then
        Sheets("Article").Select
        Sheets("Article").Copy
        ActiveWorkbook.SaveAs Filename:="C:\New Backup\Article.txt", FileFormat:=xlText, CreateBackUp:=False
        ActiveWindow.Close
        MsgBox "Sheets Article was successfully copied to C:\New Backup\Article.txt!", vbInformation
    End If
End With
'Copy Sheets Contacts And Save As Contacts.txt To C:\New Backup
With fsoObj
    If .Drives("C:").IsReady = True Then
        Sheets("Contacts").Select
        Sheets("Contacts").Copy
        ActiveWorkbook.SaveAs Filename:="C:\New Backup\Contacts.txt", FileFormat:=xlText, CreateBackUp:=False
        ActiveWindow.Close
        MsgBox "Sheets Contacts was successfully copied to C:\New Backup\Contacts.txt!", vbInformation
    End If
End With
'Copy Sheets Information And Save As Information.txt In C:\New Backup
With fsoObj
    If .Drives("C:").IsReady = True Then
        Sheets("Information").Select
        Sheets("Information").Copy
        ActiveWorkbook.SaveAs Filename:="C:\New Backup\Information.txt", FileFormat:=xlText, CreateBackUp:=False
        ActiveWindow.Close
        MsgBox "Sheets Information was successfully copied to C:\New Backup\Information.txt!", vbInformation
    End If
End With
Sheets("Start").Activate
Range("B2").Activate
Application.ScreenUpdating = True
'Create Backup Disc 1
MsgBox "Please insert Backup Disc One! Click OK to continue!", vbExclamation
'Check Drive A:\
Disc1:
With fsoObj
    If .Drives("A:").IsReady = False Then
        If MsgBox(strExcelApp & "No disc was found! Please insert Backup Disc One! Continue?", vbYesNo + vbQuestion) = vbNo Then
            MsgBox "Backup was not completed! Please create a new Backup as soon as possible!", vbCritical
            GoTo Finish
        End If
        GoTo Disc1
    End If
End With
'Clear Backup Disc One
On Error Resume Next
strPath = "A:\"
strFileMask = "*.*"
With fsoObj
    If Dir(strPath & strFileMask) <> "" Then
        Kill strPath & strFileMask
    End If
    Fs.DeleteFolder "A:\*.*", True
End With
MsgBox "Backup Disc One was successfully cleared!", vbInformation
'Copy Data.txt From C:\ To A:\
stKallFil = "C:\New Backup\Data.txt"
With fsoObj
    .CopyFile Source:=stKallFil, Destination:="a:\"
    MsgBox "Sheets Data was successfully copied from C:\New Backup\Data.txt to A:\Data.txt!", vbInformation
End With
MsgBox "Backup Disc One was successfully created!", vbInformation
'Backup Disc 2
MsgBox "Please insert Backup Disc Two! Click OK to continue!", vbExclamation
'Check Drive A:\
Disc2:
With fsoObj
    If .Drives("A:").IsReady = False Then
        If MsgBox(strExcelApp & "No disc was found! Please insert Backup Disc Two! Continue?", vbYesNo + vbQuestion) = vbNo Then
            MsgBox "Backup was not completed! Please create a new Backup as soon as possible!", vbCritical
            GoTo Finish
        End If
        GoTo Disc2
    End If
End With
'Clear Backup Disc Two
On Error Resume Next
strPath = "A:\"
strFileMask = "*.*"
With fsoObj
    If Dir(strPath & strFileMask) <> "" Then
        Kill strPath & strFileMask
    End If
    Fs.DeleteFolder "A:\*.*", True
End With
MsgBox "Backup Disc Two was successfully cleared!", vbInformation
'Copy Article.txt From C:\ To A:\
stKallFil = "C:\New Backup\Article.txt"
With fsoObj
    .CopyFile Source:=stKallFil, Destination:="a:\"
    MsgBox "Sheets Article was successfully copied from C:\New Backup\Article.txt to A:\Article.txt!", vbInformation
End With
'Copy Contacts.txt From C:\ To A:\
stKallFil = "C:\New Backup\Contacts.txt"
With fsoObj
    .CopyFile Source:=stKallFil, Destination:="a:\"
    MsgBox "Sheets Contacts was successfully copied from C:\New Backup\Contacts.txt to A:\Contacts.txt!", vbInformation
End With
'Copy Information.txt From C:\ To A:\
stKallFil = "C:\New Backup\Information.txt"
With fsoObj
    .CopyFile Source:=stKallFil, Destination:="a:\"
    MsgBox "Sheets Information was successfully copied from C:\New Backup\Information.txt to A:\Information.txt!", vbInformation
End With
MsgBox "Backup Disc Two was successfully created!", vbInformation
MsgBox "Backup completed!", vbInformation
'Delete Temporary Folder C:\New Backup And Files
Finish:
On Error Resume Next
With fsoObj
    Kill "C:\New Backup\*.*"
    MsgBox "All files in folder C:\New Backup was successfully deleted!", vbInformation
    RmDir "C:\New Backup"
    MsgBox "Folder C:\New Backup was successfully deleted!", vbInformation
End With
Set fsoObj = Nothing
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Please, be nice

/Roger