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