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 :giggle

/Roger

[jamescol]

Roger,
Can you tell us what versions of Excel and Windows are you using? And also what, if any, errors/problems you are seeing?


Thanks,
James

[Stromma]

Hi James

Thanks for your reply!

I'm using Office 2000 at home and i belive that my wife are running Office 2003 at work.

As i said in my first post, it all works ok on my machine (Office 2000).

I just want to make shure that nothing can go wrong when my wife is using the backup, because if it does i probably have the pleasure of having an extremely cold summer... :argue

/Roger

[Richie(UK)]

Hi Roger,

There is a lot of repetition in your code. Try to create separate functions/subs for code that is repeated, or use loops to repeat the common parts. This will help you to create 'modular' code that is easier to write and easier to debug.

If I get time I'll put something together later to illustrate.

[Stromma]

Hi Richie

As i said, all suggestions are more than welcome :006:

The code i posted was sort of a "step by step" code with lot's of Msgboxes etc to keep track of what was happening.

I posted it just to illustrate what i was trying to do, i'm not always shure myself :roll:

In the last version their are still some repeats. For ex:


Sheets("Data").Select
Sheets("Data").Copy
ActiveWorkbook.SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False
ActiveWindow.Close

I tried using:


Sheets("Data").SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False

But when i tried this it renamed the workbook to the last sheet, Information.txt. Another repeat is the Clear Floppy. I haven't managed to loop through this twice, so i ended up doing it once for each Disc. :dunno

The first file i copy to Disc 1 feels ok, but with the other 3 i copy one at the time and i suppose that their is a way to copy all 3 together?

Anyway, here is the "short" version. If you feel that your having to much sparetime, maybe you would be kind enough to make some comments?



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
With fsoObj
If .FolderExists("C:\New Backup\") Then
Else
.CreateFolder ("C:\New Backup")
End If
Application.ScreenUpdating = False
Sheets("Data").Select
Sheets("Data").Copy
ActiveWorkbook.SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False
ActiveWindow.Close
Sheets("Article").Select
Sheets("Article").Copy
ActiveWorkbook.SaveAs Filename:="C:\New Backup\Article.txt", FileFormat:=xlText, CreateBackUp:=False
ActiveWindow.Close
Sheets("Contacts").Select
Sheets("Contacts").Copy
ActiveWorkbook.SaveAs Filename:="C:\New Backup\Contacts.txt", FileFormat:=xlText, CreateBackUp:=False
ActiveWindow.Close
Sheets("Information").Select
Sheets("Information").Copy
ActiveWorkbook.SaveAs Filename:="C:\New Backup\Information.txt", FileFormat:=xlText, CreateBackUp:=False
ActiveWindow.Close
Sheets("Start").Activate
Range("B2").Activate
Application.ScreenUpdating = True
MsgBox "Please insert Backup Disc One! Click OK to continue!", vbExclamation
Disc1:
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
On Error Resume Next
strPath = "A:\"
strFileMask = "*.*"
If Dir(strPath & strFileMask) <> "" Then
Kill strPath & strFileMask
End If
Fs.DeleteFolder "A:\*.*", True
stKallFil = "C:\New Backup\Data.txt"
.CopyFile Source:=stKallFil, Destination:="a:\"
MsgBox "Backup Disc One was successfully created!", vbInformation
MsgBox "Please insert Backup Disc Two! Click OK to continue!", vbExclamation
Disc2:
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
On Error Resume Next
strPath = "A:\"
strFileMask = "*.*"
If Dir(strPath & strFileMask) <> "" Then
Kill strPath & strFileMask
End If
Fs.DeleteFolder "A:\*.*", True
stKallFil = "C:\New Backup\Article.txt"
.CopyFile Source:=stKallFil, Destination:="a:\"
stKallFil = "C:\New Backup\Contacts.txt"
.CopyFile Source:=stKallFil, Destination:="a:\"
stKallFil = "C:\New Backup\Information.txt"
.CopyFile Source:=stKallFil, Destination:="a:\"
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "Backup Disc Two was successfully created!", vbInformation
MsgBox "Backup completed!", vbInformation
Finish:
On Error Resume Next
Kill "C:\New Backup\*.*"
RmDir "C:\New Backup"
End With
Set fsoObj = Nothing
End Sub


/Roger :bore

[mark007]

For creating the local copies without using the selects you could use something like:



Sub CreateLocalDiskBackup()
Dim strFileName As String
strFileName = ThisWorkbook.FullName
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
SaveSheet ws.Name
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs strFileName, xlWorkbookNormal
Application.DisplayAlerts = True
End Sub

Sub SaveSheet(strName As String)
ThisWorkbook.Sheets(strName).SaveAs "C:\New Backup\" & strName & ".txt", xlText
End Sub


Also, I think you should change the code you have so far to ask before deleting everything off the floppy. Otherwise valuable data could be lost.

:)

[Stromma]

Hi Mark

Thanks for your reply!

This works fine except from an error in line:


ThisWorkbook.Sheets(strName).SaveAs "C:\New Backup\" & strName & ".txt", xlText

With this in my code it works fine:


Dim strFileName As String, ws As Worksheet
strFileName = ThisWorkbook.FullName
For Each ws In ThisWorkbook.Worksheets
SaveSheet ws.Name
Next
ThisWorkbook.SaveAs strFileName, xlWorkbookNormal


Also, I think you should change the code you have so far to ask before deleting everything off the floppy. Otherwise valuable data could be lost.
You are absolutely right!

In my original code (in swedish, i didn't have the energy to translate all msgboxex...) a vbYes/No Msgbox occur before the "Clear Floppy". I do this to prevent any errors with disc space (backup takes about 1.3 mb in each disc) when i run the code in "the right" workbook.

/Roger

[mark007]

This works fine except from an error in line:

ThisWorkbook.Sheets(strName).SaveAs "C:\New Backup\" & strName & ".txt", xlText


What's the error?

:)

[Stromma]

Hi Mark


My misstake...

Nothings wrong with your code, it works fine!

Any suggestions about the rest of the code?

As i said, it worked to begin with, but i'm sure their must be more things i can do differently?
/Roger

[mark007]

There's nothing in the rest of it that stands out as being problematic other than not asking about deleting the files. There are a few extra things that could be wrapped into subs I guess to avoid repetition but as logn as it works this isn't important really.

:)

[Stromma]

Hi All :hi:


With that last post from Mark i think the most have been said and done?

Anyway, i posted this to see what parts i could have done differently, and i learn something new every day :type

Thanks Richie, James and Mark for taking up your time reviewing this, it's highly appreciated :yes

/Roger