vba 如何将电子表格拆分为多个新电子表格，每个电子表格都包含原始数据的一个子集？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/21893913/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to split a spreadsheet into multiple new spreadsheets each containing a subset of the original data?
提问by Donotello
My excel spreadsheet contains
我的 Excel 电子表格包含
Name Grade Status
Paul 3 M
Paul 3 P
Paul 4 P
Steve 5 O
Steve 5 O
Nick 6 O
........
I used freeze paneland other formatting things .
我用过freeze panel和其他格式化的东西。
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 PSpreadsheet_Nick.xls
Name Grade Status Nick 6 o.........
Spreadsheet_paul.xls
Name Grade Status Paul 3 M Paul 3 P Paul 4 P电子表格_尼克.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 ?
我怎样才能做到这一点 ？
回答by Dmitry Pavliv
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
回答by Kapol
Assuming that you have names in cells A1:A4in Dataworksheet, the formula for Paul worksheet will be:
假设您A1:A4在Data工作表中的单元格中有名称，则 Paul 工作表的公式为：
=IFERROR(OFFSET(INDEX(Data!$A:$A,SMALL(IF(Data!$A:$A="Paul",ROW(Data!$A:$A),""),ROW(1:1))),0,COLUMN(A:A)-1),"")
Mind you, this is an arrayformula, which means that you have to enter it with the combination: Ctrl+Shift+Enter.
请注意，这是一个数组公式，这意味着您必须使用组合键输入它：Ctrl+Shift+Enter。
Now you have to just fill down and to the right to as many cells as you want.
现在，您只需向下和向右填充任意数量的单元格即可。
