我可以根据 Excel 2007 中的列将电子表格拆分为多个文件吗？

Question

Excel 中是否有办法根据单列的内容将大文件拆分为一系列较小的文件？

例如：我有一个包含所有销售代表的销售数据的文件。我需要向他们发送一个文件进行更正并发回，但我不想向他们每个人发送整个文件（因为我不想让他们更改彼此的数据）。该文件看起来像这样：

销售数据.xls

RepName          Customer        ContactEmail
Adam             Cust1           [email protected]
Adam             Cust2           [email protected]
Bob              Cust3           [email protected]
etc...

其中我需要：

销售数据_亚当.xls

RepName          Customer        ContactEmail
Adam             Cust1           [email protected]
Adam             Cust2           [email protected]

和 salesdata_Bob.xls

Bob              Cust3           [email protected]

Excel 2007 中是否有内置功能可以自动执行此操作，还是我应该分解 VBA？

Answer 1

据我所知，没有什么比宏更能分割你的数据并自动将其保存到一组文件中了。VBA 可能更容易。

更新 我实施了我的建议。它循环遍历命名范围“RepList”中定义的所有名称。命名范围是一个动态命名范围，形式为 =OFFSET(Names!$A$2,0,0,COUNTA(Names!$A:$A)-1,1)

模块如下。

Option Explicit

'Split sales data into separate columns baed on the names defined in
'a Sales Rep List on the 'Names' sheet.
Sub SplitSalesData()
    Dim wb As Workbook
    Dim p As Range

    Application.ScreenUpdating = False

    For Each p In Sheets("Names").Range("RepList")
        Workbooks.Add
        Set wb = ActiveWorkbook
        ThisWorkbook.Activate

        WritePersonToWorkbook wb, p.Value

        wb.SaveAs ThisWorkbook.Path & "\salesdata_" & p.Value
        wb.Close
    Next p
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

'Writes all the sales data rows belonging to a Person
'to the first sheet in the named SalesWB.
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
                          ByVal Person As String)
    Dim rw As Range
    Dim personRows As Range     'Stores all of the rows found
                                'containing Person in column 1
    For Each rw In UsedRange.Rows
        If Person = rw.Cells(1, 1) Then
            If personRows Is Nothing Then
                Set personRows = rw
            Else
                Set personRows = Union(personRows, rw)
            End If
        End If
    Next rw

    personRows.Copy SalesWB.Sheets(1).Cells(1, 1)
    Ser personRows = Nothing
End Sub

本工作簿包含代码和命名范围。代码是“销售数据”表的一部分。

Answer 2

为了方便后人，这里还有另一个宏来解决这个问题。

此宏将遍历指定的列，自上而下，并在遇到新值时拆分到新文件。空白或重复值将保留在一起（以及总行数），但您的列值必须排序或唯一。我主要设计它来与数据透视表布局配合使用（一旦转换为值）。

因此，无需修改代码或准备命名范围。宏首先提示用户输入要处理的列以及要开始的行号 - 即跳过标题，然后从那里开始。

当识别出某个部分时，不会将这些值复制到另一张工作表，而是将整个工作表复制到新工作簿，并删除该部分下方和上方的所有行。这样可以保留任何打印设置、条件格式、图表或您可能在其中拥有的其他任何内容，以及保留每个拆分文件中的标题，这在分发这些文件时很有用。

文件保存在 \Split\ 子文件夹中，文件名为单元格值。我尚未在各种文档上对其进行广泛测试，但它适用于我的示例文件。请随意试用，如果有问题请告诉我。

该宏可以保存为 Excel 插件 (xlam)，以便在功能区/快速访问工具栏按钮上添加按钮，以便于访问。

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2019-05-28
' Author: mtone
' Version 1.2
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 2, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1

            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0

            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If

    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Exit
        Exit Do
    End If
Loop

'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " documents saved in " + sFilePath


End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub


Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook

     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet

     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Select left-topmost cell
     ash.Cells(1, 1).Select

     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")
     sSectionName = Strings.Trim(sSectionName)

     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub

Answer 3

如果其他人用快速且正确的方法回答了这个问题，请忽略此答案。

我个人发现自己使用 Excel 时会花大量时间（有时是数小时）寻找一种复杂的方法或一个可以完成所有事情的复杂方程式，但我永远不会再使用它了...事实证明，如果我只是坐下来手动完成任务，它只会花费一小部分时间。

---

如果您只有少数人，我建议您做的是简单地突出显示所有数据，转到数据选项卡并单击排序按钮。

然后，您可以选择按哪一列进行排序，在您的情况下，您想要使用 Repname，然后只需复制并粘贴到单个文件中。

我确信使用 VBA 或其他工具，您可能会找到解决方案，但事实是，您将需要花费数小时的工作，而只需使用上述方法就可以在短时间内完成。

此外，我认为您可以在 sharepoint + excel 服务上执行此类操作，但这是一种过度的解决方案。

Answer 4

我按名称排序，然后将信息直接粘贴到第二个 Excel 工作表中，也就是您要发送的那个工作表中。Excel 只会粘贴您看到的行，而不会粘贴隐藏的行。我还保护了除我希望它们更新的单元格之外的所有单元格。哈哈。