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

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:

Code:

---

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:

Code:

---

NewName = WkbName & "_" & Wks.Name & ext

---

The full code is:

Code:

---

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.

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

Code:

---

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

---

Quote:

---

Originally Posted by SamT

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

Code:

---

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.

Code:

---

'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

---

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 :)

Code:

---

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

---

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.

Code:

---

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

---

Check out this thread. Pay attention to the posts by Kenneth and myself. format all files in a folder

Quote:

---

Originally Posted by SamT

Check out this thread. Pay attention to the posts by Kenneth and myself. 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.

Code:

---

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

---

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.

Code:

---

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

---

Thanks SamT.

Code:

---

          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?

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.

Code:

---


' 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

---

Code:

---

' 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

---

Quote:

---

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.

Code:

---

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

---

Quote:

---

Originally Posted by SamT

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:

Code:

---

        X = Wkb.Name

---

I am on Excel 2010.

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

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.")

Two ways:

Code:

---


'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

---

I'd use:

Code:

---

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

---

Quote:

---

Originally Posted by Kenneth Hobs

Two ways:

---

Many thanks Kenneth.

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