Hi,

Hopefully someone can help me with a minor glitch in the following marco. The
macro is set up so that it opens a file in the C:\Output folder formats its,
splits each worksheet into a separate workbook and saves it before moving on
to the next file in the folder. While this works well It is also meant to
include subfolders of C:\Output which is where it falls down. Any one got any
ideas where I have gone wrong?

Thanks

Public SubFolders As Boolean
Public Fso_Obj As Object, RootFolder As Object
Public SubFolderInRoot As Object, file As Object
Public RootPath As String, FileExt As String
Public MyFiles() As String, Fnum As Long
Public mybook As Workbook

Sub FSO_Example_1()



'Loop through all files in the Root folder
RootPath = "C:\Output"
'Loop through the subfolders True or False
SubFolders = True
'Loop through files with this extension
FileExt = ".xls"


'Add a slash at the end if the user forget it
If Right(RootPath, 1) < "\" Then
RootPath = RootPath & "\"
End If


Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
If Not Fso_Obj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If


Set RootFolder = Fso_Obj.GetFolder(RootPath)


'Fill the array(myFiles)with the list of Excel files in the folder(s)
Fnum = 0
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file


'Loop through the files in the Sub Folders if SubFolders = True
If SubFolders Then
For Each SubFolderInRoot In RootFolder.SubFolders
For Each file In SubFolderInRoot.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = SubFolderInRoot & "\" & file.Name
End If
Next file
Next SubFolderInRoot
End If


' Now we can open the files in the array MyFiles to do what we want
'************************************************* *****************


On Error GoTo CleanUp
Application.ScreenUpdating = False


'Loop through all files in the array(myFiles)
If Fnum 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyFiles(Fnum))
mybook.Sheets(1).Select
Application.Run "Formatsheet"
mybook.Close savechanges:=True
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub


Public Sub DeleteIfExists(CheckFileName As String)

On Error Resume Next

'Delete if file already exists
Kill CheckFileName

End Sub

Sub FormatSheet()

Dim i As Integer
Dim ShName As String
Dim ThisPath As String
Dim FullPath As String

On Error GoTo errortrap

ThisPath = ActiveWorkbook.Path

'Cycles through the worksheets
For i = 1 To Sheets().Count

Sheets(i).Activate
ShName = ActiveSheet.Name

'Skips Tree and Ls_AgXLB_WorkbookFile
If ShName = "Tree" Or ShName = "aplemnfjd781" Then GoTo NextSheet

'Changes Pageset up
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.590551181102362)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintInPlace
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 3
.PrintErrors = xlPrintErrorsDisplayed

End With

'Sets path as current path
FullPath = ThisPath & "\" & ShName & ".xls"

Call DeleteIfExists(FullPath)

'Copys sheet to new Work book
Sheets(ShName).Copy

ActiveWorkbook.SaveAs FullPath
ActiveWorkbook.Close
mybook.Activate




NextSheet:

Next i

Exit Sub

errortrap:

MsgBox "Sheet - " & ShName & " Could not be copied" & _
Chr(10) & Chr(10) & Err.Description, vbCritical

End Sub

This routine created an array named MyFiles that included all the .xls files in
my chosen folder plus the .xls files in the folders below.

It worked fine for me.

Are you sure that this is where the program is falling down?

The FormatSheet routine failed for me. My printer doesn't support that same
..printquality property. But the error message showed that as the problem.

bestie22 wrote:

Hi,

Hopefully someone can help me with a minor glitch in the following marco. The
macro is set up so that it opens a file in the C:\Output folder formats its,
splits each worksheet into a separate workbook and saves it before moving on
to the next file in the folder. While this works well It is also meant to
include subfolders of C:\Output which is where it falls down. Any one got any
ideas where I have gone wrong?

Thanks

Public SubFolders As Boolean
Public Fso_Obj As Object, RootFolder As Object
Public SubFolderInRoot As Object, file As Object
Public RootPath As String, FileExt As String
Public MyFiles() As String, Fnum As Long
Public mybook As Workbook

Sub FSO_Example_1()

'Loop through all files in the Root folder
RootPath = "C:\Output"
'Loop through the subfolders True or False
SubFolders = True
'Loop through files with this extension
FileExt = ".xls"

'Add a slash at the end if the user forget it
If Right(RootPath, 1) < "\" Then
RootPath = RootPath & "\"
End If

Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
If Not Fso_Obj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If

Set RootFolder = Fso_Obj.GetFolder(RootPath)

'Fill the array(myFiles)with the list of Excel files in the folder(s)
Fnum = 0
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file

'Loop through the files in the Sub Folders if SubFolders = True
If SubFolders Then
For Each SubFolderInRoot In RootFolder.SubFolders
For Each file In SubFolderInRoot.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = SubFolderInRoot & "\" & file.Name
End If
Next file
Next SubFolderInRoot
End If

' Now we can open the files in the array MyFiles to do what we want
'************************************************* *****************

On Error GoTo CleanUp
Application.ScreenUpdating = False

'Loop through all files in the array(myFiles)
If Fnum 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyFiles(Fnum))
mybook.Sheets(1).Select
Application.Run "Formatsheet"
mybook.Close savechanges:=True
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub

Public Sub DeleteIfExists(CheckFileName As String)

On Error Resume Next

'Delete if file already exists
Kill CheckFileName

End Sub

Sub FormatSheet()

Dim i As Integer
Dim ShName As String
Dim ThisPath As String
Dim FullPath As String

On Error GoTo errortrap

ThisPath = ActiveWorkbook.Path

'Cycles through the worksheets
For i = 1 To Sheets().Count

Sheets(i).Activate
ShName = ActiveSheet.Name

'Skips Tree and Ls_AgXLB_WorkbookFile
If ShName = "Tree" Or ShName = "aplemnfjd781" Then GoTo NextSheet

'Changes Pageset up
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.590551181102362)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintInPlace
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 3
.PrintErrors = xlPrintErrorsDisplayed

End With

'Sets path as current path
FullPath = ThisPath & "\" & ShName & ".xls"

Call DeleteIfExists(FullPath)

'Copys sheet to new Work book
Sheets(ShName).Copy

ActiveWorkbook.SaveAs FullPath
ActiveWorkbook.Close
mybook.Activate




NextSheet:

Next i

Exit Sub

errortrap:

MsgBox "Sheet - " & ShName & " Could not be copied" & _
Chr(10) & Chr(10) & Err.Description, vbCritical

End Sub

--

Dave Peterson