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