如何将电子表格拆分成多个新的电子表格，其中包含原始数据的一部分？ [英] How to split a spreadsheet into multiple new spreadsheets each containing a subset of the original data?

问题描述

我的excel电子表格包含

 姓名等级状态
保罗3 M 
保罗3 P 
保罗4 P 
史蒂夫5 O 
史蒂夫5 O 
尼克6 O 
 ........ 
  / pre> 
 
 
我使用了冻结面板和其他格式化的东西。 
 
 
 
 
 
 
我想创建一个仅包含一个名称的单独的电子表格。例如：
 
 
 
 Spreadsheet_paul.xls 
 姓名等级状态
保罗3 M 
保罗3 P 
保罗4 P 
  
 
 
 
 
 Spreadsheet_Nick.xls 
 姓名成绩状态
 Nick 6 o 
  
 ......... 
 
 
 
我需要创建单独的文件，最后文件数等于原始电子表格中的名称数量，每个文件包含原始数据的相应子集。 p> 
 
 
我该怎么做？
解决方案
我已详细评论过。但是如果你有一些问题，请在评论中问:)代码将保存当前工作簿文件夹中的新wokrbooks。
  Sub test（）
 Dim names As New集合
 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 
 
设置ws = ThisWorkbook.Worksheets（Sheet1 ）
使用ws 
'将A更改为Names的列
 lastrow = .Cells（.Rows.Count，A）。End（xlUp）.Row 
 
'将A更改为带有Names的列
对于每个单元格.Range（A2：A& lastrow）
错误恢复下一步
'收集唯一的名称
 names.Add CStr（cell.Value），CStr（cell.Value）
错误GoTo 0 
下一个单元格
 
'禁用所有过滤器s 
 .AutoFilterMode = False 
 
'更改A1：C1到表的头地址
设置rngHeader = .Range（A1：C1）
 
对于每个nm在名称
与rngHeader 
'应用过滤器到名称列
 .AutoFilter字段：= 1，条件1：= nm 
错误恢复下一步
'获取所有可见行
设置res = .Offset（2）.Resize（lastrow  -  1）.SpecialCells（xlCellTypeVisible）
错误GoTo 0 
 
'如果有可见的行，创建新的WB 
如果不是res Not Not然后
'创建新的工作簿
设置wb = Workbooks.Add 
'添加表格名称形式列名称（保罗，尼克等）
 wb.Worksheets.Add.name = nm 
'从新的wb 
删除其他工作表对于每个ws1在wb.Worksheets 
如果ws1.name<> nm然后ws1.Delete 
下一个
 
'复制/粘贴数据
带有wb.Worksheets（nm）
'复制头
 .Range（A1 ）.Resize（，rngHeader.Columns.Count）.Value = rngHeader.Value 
'复制数据
 .Range（A2）。调整大小（res.Rows.Count，res.Columns.Count ）.Value = res.Value 
 End with 
 
'save wb 
 wb.Close saveChanges：= True，Filename：= ThisWorkbook.Path& \Spreadsheet_& nm& .xlsx
设置wb =没有
结束如果
结束
下一个
'禁用所有过滤器
 .AutoFilterMode = False 
结束
 
设置名称=没有
 
 Application.DisplayAlerts = True 
 Application.ScreenUpdating = True 
 End Sub 
  
 
My excel spreadsheet contains 
Name   Grade   Status
Paul   3       M
Paul   3       P
Paul   4       P
Steve  5       O
Steve  5       O
Nick   6       O
 ........
I used freeze panel and other formatting things . 



I want to create separate Spreadsheets that would contains only one name. Example:

Spreadsheet_paul.xls
Name   Grade   Status
Paul   3       M
Paul   3       P
Paul   4       P

Spreadsheet_Nick.xls
Name   Grade   Status
Nick   6       o
.........
I need to create separate files, with the number of files at the end equal to the number of names in the original spreadsheet, each containing the corresponding subset of the original data.

How can I do this ?
解决方案
Try this code. I've commented it in details. But if you have some quesions, ask in comments:). Code saves new wokrbooks in the folder where your current workbook is saved.
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


                        
这篇关于如何将电子表格拆分成多个新的电子表格，其中包含原始数据的一部分？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！