Please help (this was at http://www.excelforum.com/excel-programming-vba-macros/1084878-save-all-worksheets-in-a-folder-incl-subfolders-as-separate-files-w-o-name-conflicts.html#post4085711 but was not resolved. That thread is now closed).
The full code (see below) is meant to allow worksheets in multiple workbooks in folders (and subfolders) to be saved as a separate files.
Ideally, the name of the resulting files would be the original workbook name + the worksheet name + some form of unique suffix to prevent duplicates. As it is, it crashes at this line when it encounters a duplicate filename:
Workbooks(Workbooks.Count).Close SaveChanges:=True, Filename:=NewName
I'm thinking that the line before this needs to be improved to prevent duplicates but I don't know how:
NewName = WkbName & "_" & Wks.Name & ext
The full code is:
Private FileFilter As String
Private oShell As Object
Function ListFiles(ByVal FolderPath As Variant, Optional ByVal SubfolderDepth As Long)
' Subfolder depth: -1 = All subfolders, 0 = No subfolders, 1 or any positive value = maximum depth
Dim dot As Long
Dim ext As String
Dim n As Long
Dim NewName As String
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Variant
Dim oShell As Object
Dim Wkb As Workbook
Dim WkbName As String
Dim Wks As Worksheet
If oShell Is Nothing Then Set oShell = CreateObject("Shell.Application")
If FileFilter = "" Then FileFilter = "*.*"
Set oFolder = oShell.Namespace(FolderPath)
If oFolder Is Nothing Then
MsgBox "The Folder '" & FolderPath & "' Does Not Exist.", vbCritical
SearchSubFolders = False
Exit Function
End If
Set oFiles = oFolder.Items
' Return all the files matching the filter.
oFiles.Filter 64, FileFilter
'Split each workbook's worksheets into new workbooks.
For n = 0 To oFiles.Count - 1
WkbName = oFolder.Self.Path & "\" & oFiles.Item(0).Name
Set Wkb = Workbooks.Open(WkbName, False, True)
dot = InStrRev(Wkb.Name, ".")
ext = Right(Wkb.Name, Len(Wkb.Name) - dot + 1)
WkbName = Wkb.Path & "\" & Left(Wkb.Name, dot - 1)
For Each Wks In Wkb.Worksheets
Wks.Copy
NewName = WkbName & "_" & Wks.Name & ext
Workbooks(Workbooks.Count).Close SaveChanges:=True, Filename:=NewName
Next Wks
Wkb.Close SaveChanges:=False
Next n
' Return subfolders in this folder.
oFiles.Filter 32, "*"
If oFiles.Count = 0 Then Exit Function
If SubfolderDepth <> 0 Then
For Each oFolder In oFiles
Call ListFiles(oFolder, SubfolderDepth - 1)
Next oFolder
End If
End Function
Sub SaveSheets()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Look for xls, xlsx, and xlsm workbooks.
FileFilter = "*.xls; *.xlsx; *.xlsm"
' Check in all subfolders.
ListFiles "C:\Test", -1
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thanks.