VBA - Split Лист Excel на несколько файлов

Question

У меня есть следующий лист в 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 

Я хотел бы разделить этот лист в файлы с помощью [ы] столбца (или столбца ND.T) Время так у меня есть эти отдельные файлы

Файл: 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 

Файл: 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 

Файл: 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 

До сих пор я нашел следующий код VBA, который отделяет файлы уникальным именем в первом столбце, так что я думаю, что это просто необходимо будет вариацией этого :

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

следующая строка:

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

должен быть

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

В исходном файле элементы в столбце один являются строками. В новом файле они являются целыми числами. В результате коллекция UniqueNames не заполняется. Вышеупомянутое исправление преобразует все элементы в столбце один в строки, прежде чем пытаться добавить их в UniqueNames.

Редактировать

Это не удается, потому что он пытается использовать дату как часть имени файла. Попробуйте заменить

OutName = OutName & UniqueNames(Index) 

с

OutName = OutName & Index 

когда разбирают на колонке даты.

Если вы хотите скопировать все столбцы, вы должны также заменить

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

с

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

Answer 2

Я думаю, что ваш код немного слишком сложны для того, что вы пытаетесь достичь , Предполагая, что у меня есть следующий лист

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

Попробуйте этот макрос (я на работе, поэтому этот макрос немного многословным это определенно может быть консолидированы поэтому я не повторять код в моем случае утверждения.):

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