Excel VBA 按部门拆分汇总表数据：快速创建每月工作表

在处理包含大量数据的 Excel 汇总表时，我们可能需要按部门或月份将数据进行拆分，以便更方便地分析和处理。本文将介绍使用 VBA 代码实现按部门拆分汇总表数据，并为每个部门创建一个包含对应月份数据的单独工作表。

代码示例

Sub SplitDataByDepartment()
    Dim wsSummary As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim deptRange As Range
    Dim deptCell As Range
    Dim monthRange As Range
    Dim monthCell As Range
    Dim destRange As Range
    Dim destCell As Range
    
    ' 设置原始汇总表工作表
    Set wsSummary = ThisWorkbook.Worksheets('汇总表')
    
    ' 在第一行插入一个新的工作表
    Sheets.Add Before:=Sheets(1)
    ' 设置新的工作表
    Set wsNew = ThisWorkbook.Worksheets(1)
    wsNew.Name = '拆分表'
    
    ' 复制原始汇总表的标题行到新的工作表
    wsSummary.Rows(1).Copy Destination:=wsNew.Rows(1)
    
    ' 获取部门范围
    lastRow = wsSummary.Cells(wsSummary.Rows.Count, 'B').End(xlUp).Row
    Set deptRange = wsSummary.Range('B2:B' & lastRow)
    
    ' 遍历部门
    For Each deptCell In deptRange
        ' 获取当前部门的名称
        deptName = deptCell.Value
        
        ' 创建新的工作表，以部门名称命名
        Sheets.Add After:=Sheets(Sheets.Count)
        Set wsNew = ActiveSheet
        wsNew.Name = deptName
        
        ' 获取当前部门的数据范围
        Set monthRange = wsSummary.Range('A2:C' & lastRow).SpecialCells(xlCellTypeVisible)
        
        ' 在新工作表的第一行复制标题行
        monthRange.Rows(1).Copy Destination:=wsNew.Rows(1)
        
        ' 遍历每个月份
        For Each monthCell In monthRange.Columns(1).Cells
            ' 获取当前月份的数据范围
            Set destRange = wsNew.Range('A2:C' & wsNew.Cells(wsNew.Rows.Count, 'A').End(xlUp).Row)
            ' 查找当前月份的数据
            Set destCell = destRange.Find(monthCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            
            ' 如果找到了当前月份的数据
            If Not destCell Is Nothing Then
                ' 复制当前月份的数据到新的工作表
                monthCell.Resize(, 3).Copy Destination:=destCell.Resize(, 3)
            End If
        Next monthCell
    Next deptCell
    
    ' 删除拆分表
    Application.DisplayAlerts = False
    Sheets('拆分表').Delete
    Application.DisplayAlerts = True
    
    ' 返回到原始汇总表
    wsSummary.Activate
End Sub

使用步骤

将上述代码复制并粘贴到 Excel VBA 编辑器的模块中（按下 ALT + F11 打开 VBA 编辑器）。
将原始汇总表的工作表名称（例如 "汇总表"）替换为代码中相应的工作表名称。
运行宏（按下 ALT + F8 并选择 "SplitDataByDepartment"）。

代码解析

代码通过以下步骤实现按部门拆分数据：

设置原始汇总表工作表：Set wsSummary = ThisWorkbook.Worksheets('汇总表')
创建临时工作表：Sheets.Add Before:=Sheets(1)
复制标题行：wsSummary.Rows(1).Copy Destination:=wsNew.Rows(1)
获取部门范围：Set deptRange = wsSummary.Range('B2:B' & lastRow)
遍历每个部门：For Each deptCell In deptRange
创建新的部门工作表：Sheets.Add After:=Sheets(Sheets.Count)
获取部门数据范围：Set monthRange = wsSummary.Range('A2:C' & lastRow).SpecialCells(xlCellTypeVisible)
复制标题行到新的工作表：monthRange.Rows(1).Copy Destination:=wsNew.Rows(1)
遍历每个月份：For Each monthCell In monthRange.Columns(1).Cells
获取当前月份数据范围：Set destRange = wsNew.Range('A2:C' & wsNew.Cells(wsNew.Rows.Count, 'A').End(xlUp).Row)
查找当前月份数据：Set destCell = destRange.Find(monthCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
复制当前月份数据到新的工作表：monthCell.Resize(, 3).Copy Destination:=destCell.Resize(, 3)
删除临时工作表：Sheets('拆分表').Delete
返回到原始汇总表工作表：wsSummary.Activate

注意事项

代码中的 "汇总表" 是原始汇总表的工作表名称，请根据实际情况修改。
代码默认月份数据在 A 列，部门数据在 B 列，其他数据在 C 列及以后。如果你的数据列位置不同，请根据实际情况修改代码中的列号。
代码使用 SpecialCells(xlCellTypeVisible) 方法获取可见单元格区域，如果你的数据包含隐藏行或列，请使用其他方法获取数据范围。

通过本文提供的 VBA 代码，你可以快速方便地按部门将汇总表中的数据拆分到不同的工作表中，提高数据整理和分析的效率。