vba - 将 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

我想按时间 [s] 列(或 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))