Option Explicit
Dim fso As FileSystemObject
Dim homeFolder As Folder
Dim backupFolder As Folder
'-------------------------
Sub CopyWorkbookAndSheets()
'----------------------------------------------------------------------------
'Purpose: To save a copy of the workbook and copy each sheet as a text file.
'Note: Code is written to be saved in a Template file which is this workbook.
'IMPORTANT: To use this code you must set a reference for Scripting Runtime
'1. In the VBE window (Alt + F11), Choose Tools | References
'2. Check the box for Microsoft Scripting Runtime
'----------------------------------------------------------------------------
Dim wb As Workbook
Dim ws As Worksheet
Dim strName As String, strFullName As String
Dim intCount As Integer
'_______________________________________________________________
'References
'---------------------------------------------------------------
Set fso = New FileSystemObject
Set wb = ThisWorkbook
Set homeFolder = fso.GetFolder(wb.Path)
'_______________________________________________________________
'Folder for backups
'---------------------------------------------------------------
If Not fso.FolderExists(homeFolder.Path & "\Backups") Then
Set backupFolder = fso.CreateFolder(homeFolder.Path & "\Backups")
Else
Set backupFolder = fso.GetFolder(homeFolder.Path & "\Backups")
End If
'_______________________________________________________________
'Save Workbook
'---------------------------------------------------------------
'File Name for Workbook Copy (XL 2003 - uses .xls file extension)
strName = wb.Name & "_" & Format(Now, "yyyy-mm-dd_hhnnss") & ".xls"
strFullName = homeFolder.Path & "\" & strName
'Save Workbook (Template is not saved...)
wb.SaveAs Filename:=strFullName, FileFormat:=xlWorkbookNormal
'---------------------------------------------------------------
'Save worksheets as text
Call SaveWorksheetsAsText(wb)
'Cleanup
If Not fso Is Nothing Then Set fso = Nothing
If Not homeFolder Is Nothing Then Set homeFolder = Nothing
If Not backupFolder Is Nothing Then Set backupFolder = Nothing
End Sub
'-------------------------------
Private Sub SaveWorksheetsAsText(ByRef wb As Workbook)
Dim ws As Worksheet
Dim strName As String
Dim strFullName As String
'_______________________________________________________________
'Save Text files
'---------------------------------------------------------------
For Each ws In wb.Worksheets
'Skip hidden sheets
If ws.Visible = xlSheetVisible Then
'Unique FileName for new file
strName = ws.Name & ".txt"
strFullName = homeFolder.Path & "\" & strName
'If file of same name exists, make a backup copy and delete
If fso.FileExists(strFullName) Then
Dim strSource As String
Dim strDest As String
strSource = strFullName
strDest = backupFolder.Path & "\" & ws.Name & "_" & Format(Now, "yyyy-mm-dd_hhnnss") & ".txt"
fso.CopyFile strSource, strDest
fso.DeleteFile strSource
End If
'Copy sheet (creates new workbook of one sheet)
ws.Copy
'Copied sheet will be active - save as text and close
With ActiveWorkbook
.SaveAs Filename:=strFullName, FileFormat:=xlText 'Or xlCSV
.Close SaveChanges:=True
End With
End If
Next ws
End Sub