JustinR
07-05-2005, 07:19 AM
Hi all.
I have written a routine to open all the .xls files in a directory, go to each sheet within them in turn, and save them with a unique filename as .csv files.
I see a mad effect that sometimes, in the saved file, I get the top half of one sheet and the bottom half of another, later, sheet! This is, obviously, fatal to my data.
Can anyone suggest a solution please?
Justin.
Here is the code (edited slightly for simplification, should still run!)
Global n as number
Sub OpenAllFilesInCurrentDirectory()
Application.DisplayAlerts = False
n = 0
' Loop through the current directory and open each
' file present
Dim strTempName As String
InputDirectory = "C:\Documents and Settings\jrowles\My Documents\xls\"
OutputDirectory = "C:\Documents and Settings\jrowles\My Documents\csv\"
Debug.Print "Clearing output directory"
' Kill (OutputDirectory & "*.*")
Debug.Print "Reading input directory"
' Make sure InputDirectory is a directory.
strTempName = Dir(InputDirectory, vbDirectory)
Do Until Len(strTempName) = 0
'Debug.Print "Considering opening " + strTempName
' Exclude ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
If (GetAttr(InputDirectory & strTempName) _
And vbDirectory) <> vbDirectory Then
If UCase(Right$(strTempName, 4)) = ".XLS" Then
'must take out the 226 and change 5 back to 2 after basic testing
If OpenAndResave(strTempName) Then
Debug.Print "Done file " + strTempName
Else
Debug.Print "Problem with file " + strTempName
End If
Else
Debug.Print "Not opening " + strTempName + " as it is does not fit the format XV...XLS"
End If
Else
Debug.Print "Not opening " + strTempName + " as it is a directory"
End If
Else
Debug.Print "Not opening " + strTempName + " as it is a default directory"
End If
' Use the Dir function to find the next filename.
strTempName = Dir()
Loop
Debug.Print "Finished"
End Sub
Function OpenAndResave(FileName As String) As Boolean
Workbooks.Open FileName:=InputDirectory + FileName
Windows(FileName).Activate
OpenAndResave = SaveSheetsByType(FileName)
ActiveWorkbook.Close
End Function
' Find out what type of sheet this is:
Function SaveSheetsByType(FileName As String) As Boolean
Dim sh As Excel.Worksheet
Dim SheetName As String
Dim i As Integer
Dim count As Integer
SaveSheetsByType = True
For Each sh In ActiveWorkbook.Sheets
SheetName = sh.Name
Sheets(SheetName).Select
SaveSheet FileName, SheetName
Next
End Function
Sub SaveSheet( _
FileName As String, _
SheetName As String, _
extension1 As Integer, _
count As Integer)
Dim NewName As String
n = n + 1
NewName = OutputDirectory & "Sheet" & n & ".csv"
On Error GoTo fail
ActiveWorkbook.SaveAs NewName, _
FileFormat:=xlCSV, _
CreateBackup:=False, _
ConflictResolution:=xlLocalSessionChanges
Exit Sub
fail:
Debug.Print "Could not save current sheet as " + NewName
End Sub
I have written a routine to open all the .xls files in a directory, go to each sheet within them in turn, and save them with a unique filename as .csv files.
I see a mad effect that sometimes, in the saved file, I get the top half of one sheet and the bottom half of another, later, sheet! This is, obviously, fatal to my data.
Can anyone suggest a solution please?
Justin.
Here is the code (edited slightly for simplification, should still run!)
Global n as number
Sub OpenAllFilesInCurrentDirectory()
Application.DisplayAlerts = False
n = 0
' Loop through the current directory and open each
' file present
Dim strTempName As String
InputDirectory = "C:\Documents and Settings\jrowles\My Documents\xls\"
OutputDirectory = "C:\Documents and Settings\jrowles\My Documents\csv\"
Debug.Print "Clearing output directory"
' Kill (OutputDirectory & "*.*")
Debug.Print "Reading input directory"
' Make sure InputDirectory is a directory.
strTempName = Dir(InputDirectory, vbDirectory)
Do Until Len(strTempName) = 0
'Debug.Print "Considering opening " + strTempName
' Exclude ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
If (GetAttr(InputDirectory & strTempName) _
And vbDirectory) <> vbDirectory Then
If UCase(Right$(strTempName, 4)) = ".XLS" Then
'must take out the 226 and change 5 back to 2 after basic testing
If OpenAndResave(strTempName) Then
Debug.Print "Done file " + strTempName
Else
Debug.Print "Problem with file " + strTempName
End If
Else
Debug.Print "Not opening " + strTempName + " as it is does not fit the format XV...XLS"
End If
Else
Debug.Print "Not opening " + strTempName + " as it is a directory"
End If
Else
Debug.Print "Not opening " + strTempName + " as it is a default directory"
End If
' Use the Dir function to find the next filename.
strTempName = Dir()
Loop
Debug.Print "Finished"
End Sub
Function OpenAndResave(FileName As String) As Boolean
Workbooks.Open FileName:=InputDirectory + FileName
Windows(FileName).Activate
OpenAndResave = SaveSheetsByType(FileName)
ActiveWorkbook.Close
End Function
' Find out what type of sheet this is:
Function SaveSheetsByType(FileName As String) As Boolean
Dim sh As Excel.Worksheet
Dim SheetName As String
Dim i As Integer
Dim count As Integer
SaveSheetsByType = True
For Each sh In ActiveWorkbook.Sheets
SheetName = sh.Name
Sheets(SheetName).Select
SaveSheet FileName, SheetName
Next
End Function
Sub SaveSheet( _
FileName As String, _
SheetName As String, _
extension1 As Integer, _
count As Integer)
Dim NewName As String
n = n + 1
NewName = OutputDirectory & "Sheet" & n & ".csv"
On Error GoTo fail
ActiveWorkbook.SaveAs NewName, _
FileFormat:=xlCSV, _
CreateBackup:=False, _
ConflictResolution:=xlLocalSessionChanges
Exit Sub
fail:
Debug.Print "Could not save current sheet as " + NewName
End Sub