vba 为每个过滤结果创建一个单独的 excel 文件
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/10124576/
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
Creating a separate excel file for each filter result
提问by Stephen Allan
I have a spreadsheet which I want to split to separate spreadsheets for each department there are more then the departments shown and I want the .xls files for each to be save with the department name
我有一个电子表格，我想将其拆分为每个部门的单独电子表格，还有更多的部门显示，我希望每个部门的 .xls 文件都与部门名称一起保存
The department field is column D.
部门字段是列 D。
i.e. I would like an .xls file for each with only the records for department 1, department 2, and so on.
即我想要一个 .xls 文件，每个文件只包含部门 1、部门 2 等的记录。
Unfortunately I am unable to post a screenshot of the spreadsheet as my rep isn't good enough yet.
不幸的是，我无法发布电子表格的屏幕截图，因为我的代表还不够好。
What VBA code would I use to do this?
我将使用什么 VBA 代码来执行此操作？
回答by Daniel
This should do what you need. If you run it and provide a column letter it will base it on that column, otherwise it'll default to D as you specified:
这应该做你需要的。如果您运行它并提供一个列字母，它将基于该列，否则它将默认为您指定的 D ：
Sub SplitWorkbook(Optional colLetter As String, Optional SavePath As String)
If colLetter = "" Then colLetter = "D"
Dim lastValue As String
Dim hasHeader As Boolean
Dim wb As Workbook
Dim c As Range
Dim currentRow As Long
hasHeader = True 'Indicate true or false depending on if sheet has header row.
If SavePath = "" Then SavePath = ThisWorkbook.Path
'Sort the workbook.
ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ThisWorkbook.Worksheets(1).Sort
.SetRange Cells
If hasHeader Then ' Was a header indicated?
.Header = xlYes
Else
.Header = xlNo
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For Each c In ThisWorkbook.Sheets(1).Range("D:D")
If c.Value = "" Then Exit For
If c.Row = 1 And hasHeader Then
Else
If lastValue <> c.Value Then
If Not (wb Is Nothing) Then
wb.SaveAs SavePath & "\" & lastValue & ".xls"
wb.Close
End If
lastValue = c.Value
currentRow = 1
Set wb = Application.Workbooks.Add
End If
ThisWorkbook.Sheets(1).Rows(c.Row & ":" & c.Row).Copy
wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select
wb.Sheets(1).Paste
End If
Next
If Not (wb Is Nothing) Then
wb.SaveAs SavePath & "\" & lastValue & ".xls"
wb.Close
End If
End Sub
This will generate a separate workbook in the same folder as the work book you run this from... or in the path you provide.
这将在与您运行它的工作簿相同的文件夹中生成一个单独的工作簿...或在您提供的路径中。
