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

Question

我有一个电子表格，我想将其拆分为每个部门的单独电子表格，显示的部门多于显示的部门，我希望将每个部门的 .xls 文件与部门名称一起保存

部门字段是 D 列。

即，我想要一个 .xls 文件，每个文件只包含部门 1、部门 2 等的记录。

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

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

这将在与您运行它的工作簿相同的文件夹中生成一个单独的工作簿......或在您提供的路径中。