为每个过滤结果创建一个单独的excel文件

Question

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

部门字段列D.

即我想对于每个仅记录部门1，部门2 .xls文件，等等。

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

我会用什么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 

这将在同一文件夹中的工作簿生成单独的工作簿时从...或者您提供的路径运行。