Coping with duplicates being created by code splitting worksheets into separate files

[1819]

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 (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.

[SamT]

If that is the only time it crashes, use it to your advantage


On Error Resume Next
Workbooks(Workbooks.Count).Close SaveChanges:=True, Filename:=NewName
If Err.Number <> 0 then Workbooks(Workbooks.Count).Close SaveChanges:=False
Error = 0

[1819]

If that is the only time it crashes, use it to your advantage


On Error Resume Next
Workbooks(Workbooks.Count).Close SaveChanges:=True, Filename:=NewName
If Err.Number <> 0 then Workbooks(Workbooks.Count).Close SaveChanges:=False
Error = 0

Thanks, SamT, but it's still crashing at 2nd instance of line "Workbooks(Workbooks.Count).Close SaveChanges:=True, Filename:=NewName" shown below. Have I inserted your code correctly? Thanks.



'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
On Error Resume Next
Workbooks(Workbooks.Count).Close SaveChanges:=True, Filename:=NewName
If Err.Number <> 0 Then Workbooks(Workbooks.Count).Close SaveChanges:=False
Error = 0
Next Wks
Wkb.Close SaveChanges:=False
Next n

[SamT]

I think I found several errors, but I don't have the complete procedure, so :dunno

I'm not sure what you need so I added an alternate that adds a Date.Time stamp to the name. I put yours at the end of the name so the files would show those with the same names together, newest last; like "WkbName_ShtName_42155.5530.xls." I use 4 decimals because there are almost 10,000 seconds in a day and I need that resolution in my backups. YMMV :)

Sub SamT()
'Split each workbook's worksheets into new workbooks.
For n = oFiles.Count To 0 Step -1
WkbName = oFolder.Self.Path & "\" & oFiles.Item(n).Name
Set Wkb = Workbooks.Open(WkbName, False, True)
Dot = InStrRev(Wkb.Name, ".")
ext = Right(Wkb.Name, Len(Wkb.Name) - Dot + 1)


For Each Wks In Wkb.Worksheets
Wks.Copy
NewName = WkbName & "_" & Wks.Name & ext
'Alternate. Serialize new book names with Date.Time
' NewName = WkbName & "_" & Wks.Name & "_" & Left(CStr(CDbl(Now)), 10) & ext

Workbooks("Book1" & Dot & ext).Name = NewName '<< Maybe. I just hate using "Count" when there is an alternative.

'Do not replace existing workbook with new book. See alternate
On Error Resume Next
Workbooks(NewName).SaveAs Wkb.Path & "\" & NewName
If Err.Number <> 0 Then Workbooks(NewName).Close SaveChanges:=False
Error = 0
'Remove above 4 lines if using alternate

'Alternate. Serialize new book names with timestamp. Keep existing workbboks
' Workbooks(NewName).SaveAs Wkb.Path & "\" & NewName
' Workbooks(NewName).Close
Next Wks
Wkb.Close
Next n
End Sub

[1819]

Many thanks, SamT. I inserted your code but the only way I can get the macro to work is using the code below, which simply opens each worksheet as a file called "Book" with a sequential suffix (Book1.....Book300, whatever). I can't get the macro to name the new files with unique names, and keeping existing workbooks, as attempted in your last post. I suspect it's because I haven't inserted your code properly. Please could you take a look? Many thanks.



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
'SOMETHING GOING WRONG AROUND HERE?
NewName = WkbName & "_" & Wks.Name & "_" & Left(CStr(CDbl(Now)), 10) & ext
Next Wks
Wkb.Close
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

[SamT]

Check out this thread. Pay attention to the posts by Kenneth and myself. format all files in a folder (http://www.vbaexpress.com/forum/showthread.php?52649-format-all-files-in-a-folder)

[1819]

Check out this thread. Pay attention to the posts by Kenneth and myself. format all files in a folder (http://www.vbaexpress.com/forum/showthread.php?52649-format-all-files-in-a-folder)

Thanks. I have studied that thread closely and concluded that the code in post # 58 was probably the most relevant. However, I could not work out how to:

a) adapt #58 to replace my current code OR
b) merge part of my current code with #58.

For convenience, here's the code at #58. Very grateful for any help.



Option Explicit

Sub SNB__KenH_SamT()
Dim Filename As String
Dim NameLength As Long

Dim FileNameArray As Variant 'sn
Dim FileLinesArray As Variant 'sp

Dim Formula1LinesArray As Variant
Dim Formula1Result As Double 'y
'Repeat these two lies for each Formula. Edit the numbers to suit
Dim Formula2LinesArray As Variant
Dim Formula2Result As Double

Dim Fn As Long 'Fn = Index number for FileNameArray 'jj
Dim Fl As Long 'Fl = FileLinesArray Index number 'j

Const FolderPath As String = "C:\Users\dbrandejs\david\skola\IES\Diplomka\adjusted data\allstocks_20130102\" 'include ending \


'''' Put all the file names in the path in Array
FileNameArray = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & _
FolderPath & "*.csv /b /s").stdout.readall, vbCrLf), ".")


'''' Open one file at a time
With CreateObject("scripting.filesystemobject")
For Fn = 0 To UBound(FileNameArray)



MsgBox "Working on File " & FileNameArray(Fn)


''''Put all lines from one file in Arrays
FileLinesArray = Split(.opentextfile(FileNameArray(Fn)).readall, vbLf)
Formula1LinesArray = FileLinesArray
Formula2LinesArray = FileLinesArray
'Initializ
Formula1Result = 0
Formula2Result = 0
''''Calcuate first result for one file

For Fl = 0 To UBound(FileLinesArray) - 1



MsgBox " Line #" & Fl + 1 & " is" & vbCrLf & FileLinesArray(Fl)



'''' Calculate first formula
'Replace file line with Log of 6th value. Split(BlahBlah)(5)
Formula1LinesArray(Fl) = Log(Split(Formula1LinesArray(Fl), ",")(5))
'After the first line
If Fl > 0 Then Formula1Result = Formula1Result + Formula1Result + _
(Formula1LinesArray(Fl) - Formula1LinesArray(Fl - 1) ^ 2) * 100



Dim MsgAnswer
MsgAnswer = MsgBox("The Result is " & Formula1Result & vbCrLf & vbCrLf _
& "Press Cancel to stop run.", vbOkCancel)
If MsgAnswer = vbCancel Then Exit Sub



'''' Calculate second Formula here
'Replace file line with first part of formula. Think carefully
'Formula2LinesArray (Fl) = Your formula here

Next Fl

'''' Put results in sheet

'Get FileName
NameLength = Len(FileNameArray(Fn)) - InStrRev(FileNameArray(Fn), "\")
Filename = Right(FileNameArray(Fn), NameLength)

'Place result
With ActiveSheet.Rows(Fn + 1)
.Columns(2) = Formula1Result 'Column B
'.Columns(3) = Formula2Result
.Columns(1) = Filename
End With

'Initialize Arrays
FileLinesArray = ""
Formula1LinesArray = FileLinesArray
Formula2LinesArray = FileLinesArray


Next Fn 'Work on next File
End With
End Sub

[SamT]

Lets go back the hte beginning and take care of the duplicates problem. This code is from your first post. IF it worked before, it should work now with no duplicates. After this is proven, then, if you want, we can incorporate snb's method of file handling from the above mentioned thread.


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 NewBook 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
NewName = WkbName & "_" & Wks.Name '<-<-<-<-
Wks.Copy
'Immediately set a variable the newly created book
Set NewBook = Workbooks(Workbooks.Count) '<<<<<<<<<<<<<<<<<
NewBook.SaveAs NewName & "_" & Left(CStr(CDbl(Now)), 10) & ext '<<<<<<<<<<<<<<
NewBook.Close '<<<<<<<<<<<<<
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

[1819]

Thanks SamT.



NewBook.SaveAs NewName & "_" & Left(CStr(CDbl(Now)), 10) & ext '<<<<<<<<<<<<<<


Code breaks down at that line according to debugger. It seems that code wants to cycle through the first file tested over and over again, producing further versions of the same worksheets. It needs to know that it's done its job on the file and should move on.

The main issue seems to be that, rather than just splitting all the worksheets into new files, it also wants to create a new file containing all the worksheets together. If that could be prevented, it is likely the problem may go away.

Any ideas?

[Kenneth Hobs]

Fully defining your goals is usually the best way to get help.

I notice that you don't post often in this forum nor Excelforum.com. I also see that you give up and put a message that you consider the thread closed. Let the moderators do that. Some forums let you mark a thread SOLVED but if you do, say no solution was found but even then, I suggest doing that as a last resort though do marked solved when it is. IF you don't see a response in say 2 days, then put a short reply and say bump, or still need help or send a Private Message (PM) to some that were helping but may have forgotten. I know that in one here, I was going to give more help but I am busy and forgot about the thread and I do help others in this forum and others. That is why cross-posting is generally, not a good idea.

I have not gotten into this thead because of all the fine help that you received at both forums. Even so, sometimes a fresh set of eyes can help.

I see two approaches to solve your latest request to just save the worksheets only as separate files. The first method, involves saving to a CSV file. I will post two ways to do that. The second approach is to Copy each file, open it, and then delete all but the sheet of interest. This saves your formats but does take a bit more work and is a bit slower. I think this last method that I did was one chosen for a top 100 tips publication by MrExcel.




' http://www.vbaexpress.com/forum/showthread.php?t=42769
Public Sub SaveAllShtCSV()

Dim wbThis As Workbook, i As Integer
Dim colDelimiter As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
colDelimiter = Application.International(xlColumnSeparator)

'Application.International(xlColumnSeparator) = ";"
Set wbThis = ThisWorkbook
For i = 1 To wbThis.Sheets.Count
wbThis.Sheets(i).Copy
With ActiveWorkbook
.SaveAs FileName:=ThisWorkbook.Path & "\" & wbThis.Sheets(i).Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False 'Change path to suit
'xlCSV does same as xlCSVWindows
.Close
End With
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Application.International(xlColumnSeparator) = colDelimiter

End Sub





' http://www.vbaexpress.com/forum/showthread.php?t=42769
Sub ExportSheets()
Dim ws As Worksheet, exportPath As String, s As String
exportPath = ThisWorkbook.Path & "\"
For Each ws In Worksheets
With ws
' http://www.cpearson.com/excel/ImpText.aspx
ExportToTextFile ThisWorkbook.Path & "\" & .Name & ".txt" _
, ";", False, False
End With
Next ws
End Sub

[SamT]

Code breaks down at that line according to debugger. It seems that code wants to cycle through the first file tested over and over again, producing further versions of the same worksheets. It needs to know that it's done its job on the file and should move on.

The main issue seems to be that, rather than just splitting all the worksheets into new files, it also wants to create a new file containing all the worksheets together. If that could be prevented, it is likely the problem may go away.

What does that mean?

Dim n as a Variant. You have been looping thru the code n number of times, but you had used a zero instead of n for the file to open.

couldn't find that issue.

You do realize that this code will also convert the workbook that it is in?

This version works on my machine.

Option Explicit

Function ListFiles()

' 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 Variant
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 NewBook As Workbook '<<<<<<<<<<<<<<<<<<<<<
Dim WkbName As String
Dim Wks As Worksheet
Dim FileFilter As String
Const FolderPath As Variant = "C:\CSVs\A\"

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(n).Name
Set Wkb = Workbooks.Open(WkbName, False, True)
X = Wkb.Name
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
NewName = WkbName & "_" & Wks.Name '<-<-<-<-
Wks.Copy
'Immediately set a variable the newly created book
Set NewBook = Workbooks(Workbooks.Count) '<<<<<<<<<<<<<<<<<
NewBook.SaveAs NewName & "_" & Left(CStr(CDbl(Now)), 10) & ext '<<<<<<<<<<<<<<
NewBook.Close '<<<<<<<<<<<<<
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

[1819]

This version works on my machine.


Many thanks SamT for persevering with this and welcome back Kenneth - thank you for your input too.

If I can respond to SamT first, unfortunately I am getting a message box saying "Compile error: Variable not defined".

and then the debugger points to this line in the code:



X = Wkb.Name


I am on Excel 2010.

[SamT]

Delete all lines with X=
I use them for testing/troubleshooting and obviously I deleted the Dim X line.

[1819]

SamT, to confirm post 11 (minus the line X = Wkb.Name) works extremely well. Many thanks indeed.

Before I mark the thread "solved", I wonder if Kenneth would be kind enough to post his alternate method ("The second approach is to Copy each file, open it, and then delete all but the sheet of interest. This saves your formats but does take a bit more work and is a bit slower. I think this last method that I did was one chosen for a top 100 tips publication by MrExcel.")

[Kenneth Hobs]

Two ways:



'http://www.excelforum.com/excel-programming/673275-single-sheet-saveas-without-changing-workbook-fileformat.html#post2049123
Sub Test_CopySheet()
Dim oSheet As Worksheet
Dim prefix As String
Dim thePath As String

prefix = "Master_"
thePath = ThisWorkbook.Path & "\"

For Each oSheet In ThisWorkbook.Sheets
CopySheet oSheet, thePath, prefix
Next oSheet
End Sub


Sub CopySheet(sht As Worksheet, thePath As String, prefix As String)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)
sht.Copy after:=wb.Sheets(1)
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
wb.ActiveSheet.Name = sht.Name
wb.SaveAs thePath & prefix & sht.Name & ".xls"
wb.Close False
End Sub


Sub Test_SaveSheet()
Dim sht As Worksheet
For Each sht In ThisWorkbook.Sheets
SaveSheet sht.Name, ThisWorkbook.Path & "\Mater_" & sht.Name & ".xls"
Next sht
End Sub


'http://www.excelforum.com/excel-programming/673275-single-sheet-saveas-without-changing-workbook-fileformat.html#post2049123
Sub SaveSheet(shtName As String, fName As String, _
Optional xlFileFormat As Long = xlWBATWorksheet)
If Dir(fName) <> "" Then Kill fName
ThisWorkbook.SaveCopyAs fName
Workbooks.Open fName
'Application.DisplayAlerts = False
Worksheets(shtName).SaveAs Filename:=fName, FileFormat:=xlFileFormat
Application.DisplayAlerts = True
ActiveWorkbook.Close False
End Sub

[snb]

I'd use:


Sub M_snb()
c00="G:\OF\"

sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir """ & c00 &"*.xls*"" /b/s").stdout.readall, vbCrLf), ".")

For j = 0 To UBound(sn)
With GetObject(sn(j))
For Each sh In .Sheets
sh.Copy
With ActiveWorkbook
.SaveAs Replace(Replace(sn(j), "\", "_"), ".xls", "_" & sh.Name & "_"), 51
.Close 0
End With
Next
.Close 0
End With
Next
End Sub

[1819]

Two ways:


Many thanks Kenneth.

[1819]

Thank you for your help, snb. Thanks to this thread and everyone's patience I have exactly what I was looking for.