vba – 将Excel工作表分成多个文件
我在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 我想通过Time [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
到目前为止，我已经find了下面的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
以下行：
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)
在原始文件中，第一列中的项目是string。 在新文件中，它们是整数。 因此，UniqueNames集合没有被填充。 上述修补程序在尝试将它们添加到UniqueNames之前将第一列中的所有项目转换为string。
编辑
这是失败的，因为它试图使用date作为文件名的一部分。 尝试更换
OutName = OutName & UniqueNames(Index)
同
OutName = OutName & Index
当你在date列上sorting。
如果你想复制所有的列，你也应该replace
Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol))
同
Set FilterRange = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol))
我认为你的代码对你想要完成的事情有一点牵扯。 假设我有以下工作表
ID ID2 1 1 1 2 1 3 1 4 2 3 2 4 2 5 2 6
尝试这个macros（我在工作，所以这个macros有点冗长，这肯定可以巩固，所以我不重复代码在我的if语句）：
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