![](/img/trans.png)
[英]Solution for Dividing WorkSheet into Multiple Files with vba/excel/c#
[英]vba - Split Excel Worksheet into multiple files
我在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
以下行:
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))
我认为你的代码对于你想要完成的事情来说有点过于复杂。 假设我有以下工作表
ID ID2
1 1
1 2
1 3
1 4
2 3
2 4
2 5
2 6
试试这个宏(我正在工作,所以这个宏有点冗长。这绝对可以合并,所以我不会在我的 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.