为每个filter结果创build一个单独的excel文件

我有一个电子表格，我想拆分为每个部门分开的电子表格，有更多的部门显示，我希望每个.xls文件保存与部门名称

部门领域是专栏D.

即我想每个.xls文件只有部门1，部门2，等等的logging。

不幸的是，我无法发布电子表格的屏幕截图，因为我的代表还不够好。

我会用什么VBA代码来做到这一点？

Answer 1

这应该做你需要的。 如果你运行它，并提供一个列字母，它将基于该列，否则它会默认为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 

这将在与您运行的工作簿相同的文件夹或您提供的path中生成单独的工作簿。