使用VBA将Excel工作表拆分为多个文件

Question

使用VBA将Excel工作表拆分为多个文件

4

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

我希望将这张表格按照时间[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

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

到目前为止，我找到了以下的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

- Labrat

绝对没有任何反应？如果你逐步执行，它是否找到了正确的lastrow和lastcol？ - Sun

2个回答

0

我认为你的代码有点过于复杂，超出了你想要实现的目标。假设我有以下工作表

你可以尝试这个宏（我在工作中，所以这个宏有点啰嗦。这个宏肯定可以合并，这样我的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

- jellz77

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- poppertech · Accepted Answer

以下是一行代码：

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))