Question

我的Excel电子表格包含

Name   Grade   Status
Paul   3       M
Paul   3       P
Paul   4       P
Steve  5       O
Steve  5       O
Nick   6       O
 ........

我使用了freeze panel和其他格式化的东西。

我想创建单独的Spreadsheets，它只包含一个名称。例如：

Spreadsheet_paul.xls

Name   Grade   Status
Paul   3       M
Paul   3       P
Paul   4       P

Spreadsheet_Nick.xls
```
Name   Grade   Status
Nick   6       o
```
.........

我需要创建单独的文件，最后的文件数量等于原始电子表格中的名称数量，每个文件都包含原始数据的相应子集。

我该怎么做？

Answer 1

试试这段代码。我已经详细评论了它。但如果你有一些问题，请在评论中提问:)。代码将新的wokrbooks保存在保存当前工作簿的文件夹中。

Sub test()
    Dim names As New Collection
    Dim ws As Worksheet, ws1 As Worksheet
    Dim wb As Workbook
    Dim lastrow As Long
    Dim cell As Range
    Dim nm As Variant
    Dim res As Range
    Dim rngHeader As Range

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws
        'change "A" to column with "Names"
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'change "A" to column with "Names"
        For Each cell In .Range("A2:A" & lastrow)
            On Error Resume Next
            'collect unique names
            names.Add CStr(cell.Value), CStr(cell.Value)
            On Error GoTo 0
        Next cell

        'disable all filters
        .AutoFilterMode = False

        'change "A1:C1" to headers address of your table
        Set rngHeader = .Range("A1:C1")

        For Each nm In names
            With rngHeader
                'Apply filter to "Name" column
                .AutoFilter Field:=1, Criteria1:=nm
                On Error Resume Next
                'get all visible rows 
                Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0

                'if there is visible rows, create new WB
                If Not res Is Nothing Then
                    'create new workbook
                    Set wb = Workbooks.Add
                    'add sheet with name form column "Names" ("Paul", "Nick" or etc)
                    wb.Worksheets.Add.name = nm
                    'delete other sheets from new wb
                    For Each ws1 In wb.Worksheets
                        If ws1.name <> nm Then ws1.Delete
                    Next

                    'copy/paste data
                    With wb.Worksheets(nm)
                        'copy headers
                        .Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
                        'copy data
                        .Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
                    End With

                    'save wb
                    wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
                    Set wb = Nothing
                End If
            End With
        Next
        'disable all filters
        .AutoFilterMode = False
    End With

    Set names = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Answer 2

假设您在A1:A4工作表中的单元格Data中有名称，Paul工作表的公式将为：

=IFERROR(OFFSET(INDEX(Data!$A$1:$A$4,SMALL(IF(Data!$A$1:$A$4="Paul",ROW(Data!$A$1:$A$4),""),ROW(1:1))),0,COLUMN(A:A)-1),"")

请注意，这是一个数组公式，这意味着您必须使用以下组合输入：Ctrl + Shift + Enter。

现在你必须向右和向右填充任意数量的单元格。

如何将电子表格拆分为多个新电子表格，每个电子表格都包含原始数据的子集？

2 个答案: