vba - Split Excel Worksheet into multiple files

Question

I have the following sheet in excel:

ID  ND.T    Time [s]    Position X [%s] Position Y [%s] Speed [%s]  Area [%s]   Width [%s]  MeanIntensity
1   1        3.87         417.57          11.46          0.06        339.48       14.1          245.65
1   2        8.72         417.37          11.68          0.04        342.61       14.15         239.34
1   3        13.39        417.57          11.66          0.04        344.17       14.3          239.48
2   1        3.87         439.01          6.59           0.02        342.61       11.66         204.47
2   2        8.72         438.97          6.65           0.007       342.61       10.7          197.96
2   3        13.39        438.94          6.66           0.03        345.74       11.03         214.74

I would like to separate this sheet into files by the Time [s] column (or ND.T column) so I have these separate files

File: 3.87.xlxs

ID  ND.T    Time [s]    Position X [%s] Position Y [%s] Speed [%s]  Area [%s]   Width [%s]  MeanIntensity
  1 1        3.87         417.57          11.46          0.06        339.48       14.1          245.65
  2 1        3.87         439.01          6.59           0.02        342.61       11.66         204.47

File: 8.72.xlxs

ID  ND.T    Time [s]    Position X [%s] Position Y [%s] Speed [%s]  Area [%s]   Width [%s]  MeanIntensity
1   2        8.72         417.37          11.68          0.04        342.61       14.15         239.34
2   2        8.72         438.97          6.65           0.007       342.61       10.7          197.96

File : 13.39.xlxs

ID  ND.T    Time [s]    Position X [%s] Position Y [%s] Speed [%s]  Area [%s]   Width [%s]  MeanIntensity
1   3        13.39        417.57          11.66          0.04        344.17       14.3          239.48
2   3        13.39        438.94          6.66           0.03        345.74       11.03         214.74

So far I have found the following VBA code which separates files by a unique name in the first column, so I think it would just need to be a variation of this:

    Option Explicit
Sub SplitIntoSeperateFiles()

Dim OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim FilterRange As Range
Dim UniqueNames As New Collection
Dim LastRow As Long, LastCol As Long, _
    NameCol As Long, Index As Long
Dim OutName As String

'set references and variables up-front for ease-of-use
Set DataSheet = ThisWorkbook.Worksheets("Sheet1")
NameCol = 1
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol))

'loop through the name column and store unique names in a collection
For Index = 2 To LastRow
    On Error Resume Next
        UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol)
    On Error GoTo 0
Next Index

'iterate through the unique names collection, writing
'to new workbooks and saving as the group name .xls
Application.DisplayAlerts = False
For Index = 1 To UniqueNames.Count
    Set OutBook = Workbooks.Add
    Set OutSheet = OutBook.Sheets(1)
    With FilterRange
        .AutoFilter Field:=NameCol, Criteria1:=UniqueNames(Index)
        .SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1")
    End With
    OutName = ThisWorkbook.FullName
    OutName = Left(OutName, InStrRev(OutName, "\"))
    OutName = OutName & UniqueNames(Index)
    OutBook.SaveAs Filename:=OutName, fileFormat:=xlExcel8
    OutBook.Close SaveChanges:=False
    Call ClearAllFilters(DataSheet)
Next Index
Application.DisplayAlerts = True

End Sub

'safely clear all the filters on data sheet
Sub ClearAllFilters(TargetSheet As Worksheet)
    With TargetSheet
        TargetSheet.AutoFilterMode = False
        If .FilterMode Then
            .ShowAllData
        End If
    End With
End Sub

Answer 1

The following line:

UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol)

should be

UniqueNames.Add Item:=CStr(DataSheet.Cells(Index, NameCol).Value), Key:=CStr(DataSheet.Cells(Index, NameCol).Value)

In the original file, the items in column one are strings. In the new file, they are integers. As a result, the UniqueNames collection is not being filled. The above fix converts all of the items in column one to strings before attempting to add them to UniqueNames.

Edit

It is failing because it is trying to use the date as part of the file name. Try replacing

OutName = OutName & UniqueNames(Index)

with

OutName = OutName & Index 

when you are sorting on the date column.

If you want to copy all of the columns, you should also replace

Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol)) 

with

Set FilterRange = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol)) 

Answer 2

I think your code is a little too involved for what you're trying to accomplish. Assuming i have the following worksheet

ID  ID2
1   1
1   2
1   3
1   4
2   3
2   4
2   5
2   6

Try this macro (i'm at work, so this macro is a bit verbose. this can definitely be consolidated so i'm not repeating code in my if statements):

Sub asdf()
    Dim a As Worksheet
    Dim b As Worksheet

    Set a = Sheets("Sheet1")

    currentId = ""

    For x = 2 To a.Range("a65536").End(xlUp).Row 'get to the last row
        If currentId = "" Then
            currentId = x
            If a.Range("a" & currentId).Value <> a.Range("a" & x + 1).Value Then
                a.Range(Range("a" & x), a.Range("b" & currentId)).Select
                a.Range(Range("a" & x), Range("b" & currentId)).Copy
                Workbooks.Add
                Set b = ActiveSheet
                b.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial
                ActiveWorkbook.SaveAs Filename:="C:\ENTER PATH HERE\" & a.Range("a" & x).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                ActiveWorkbook.Close
                currentId = ""
            End If
        ElseIf Range("a" & currentId).Value <> a.Range("a" & x + 1).Value Then
            a.Range(Range("a" & x), a.Range("b" & currentId)).Select
            a.Range(Range("a" & x), Range("b" & currentId)).Copy
            Workbooks.Add
            Set b = ActiveSheet
            b.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial
            ActiveWorkbook.SaveAs Filename:="C:\ENTER PATH HERE\" & a.Range("a" & x).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            ActiveWorkbook.Close
            currentId = ""
        Else
            '
        End If
    Next x

End Sub