请求编写VBA代码：按部门拆分销售日志工作簿并覆盖旧报表

以下是完整的VBA代码，直接复制到Excel的VBA编辑器中即可使用，代码会自动按部门拆分数据、保留原格式，并覆盖指定路径下上周的旧报表：

Sub SplitSalesLogByDepartment()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wbDest As Workbook
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim deptCol As Integer ' 部门所在列，这里假设是第3列（C列），可根据实际修改
    Dim deptRange As Range
    Dim deptCell As Range
    Dim uniqueDepts As Collection
    Dim deptName As Variant
    Dim savePath As String ' 拆分后文件保存路径，需自行修改
    
    ' -------------------------- 自定义设置 --------------------------
    Set wbSource = ThisWorkbook ' 假设中心日志就是当前运行代码的工作簿，也可改为Workbooks.Open("你的文件路径")
    Set wsSource = wbSource.Worksheets("销售日志") ' 源工作表名称，根据实际修改
    deptCol = 3 ' 部门列的列号，A=1, B=2, C=3...
    savePath = "C:\销售报表拆分\" ' 保存路径，需确保该文件夹已存在
    ' ----------------------------------------------------------------
    
    ' 获取源数据的最后行和最后列
    lastRow = wsSource.Cells(wsSource.Rows.Count, deptCol).End(xlUp).Row
    lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
    
    ' 收集所有唯一的部门名称
    Set uniqueDepts = New Collection
    On Error Resume Next
    For Each deptCell In wsSource.Range(wsSource.Cells(2, deptCol), wsSource.Cells(lastRow, deptCol))
        If deptCell.Value <> "" Then
            uniqueDepts.Add deptCell.Value, Key:=CStr(deptCell.Value)
        End If
    Next deptCell
    On Error GoTo 0
    
    ' 循环处理每个部门
    For Each deptName In uniqueDepts
        ' 创建新工作簿
        Set wbDest = Workbooks.Add
        Set wsDest = wbDest.Worksheets(1)
        wsDest.Name = "部门销售数据"
        
        ' 复制表头（含格式）
        wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)).Copy
        wsDest.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        wsDest.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
        
        ' 筛选当前部门的数据
        wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).AutoFilter Field:=deptCol, Criteria1:=deptName
        
        ' 复制筛选后的数据（含格式）
        wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible).Copy
        wsDest.Cells(2, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        
        ' 取消筛选
        wsSource.AutoFilterMode = False
        
        ' 调整目标工作表列宽（确保和源表一致）
        wsDest.UsedRange.Columns.AutoFit
        
        ' 处理文件覆盖：如果旧报表存在则删除
        Dim fullFileName As String
        fullFileName = savePath & deptName & "销售报表.xlsx"
        If Dir(fullFileName) <> "" Then
            Kill fullFileName
        End If
        
        ' 保存目标工作簿，格式匹配源文件
        wbDest.SaveAs Filename:=fullFileName, FileFormat:=wbSource.FileFormat
        
        ' 关闭目标工作簿
        wbDest.Close SaveChanges:=False
    Next deptName
    
    ' 释放对象
    Set wsDest = Nothing
    Set wbDest = Nothing
    Set wsSource = Nothing
    Set wbSource = Nothing
    
    MsgBox "拆分完成！所有部门报表已覆盖更新。"
End Sub

关键部分说明 #

• 自定义设置区块：你需要根据实际情况修改这部分内容，包括源工作簿路径（如果不是当前工作簿）、源工作表名称、部门所在列号、报表保存路径。
• 唯一部门收集：通过Collection对象自动去重，避免重复创建相同部门的报表。
• 格式保留：使用xlPasteAllUsingSourceTheme复制所有格式、样式，再单独复制列宽，确保新报表和源日志格式完全一致。
• 旧报表覆盖：通过Dir检查文件是否存在，存在则用Kill删除后再保存，确保每周运行时自动替换旧文件。
• 资源释放：最后手动释放所有对象变量，避免内存占用。

使用注意事项 #

1. 打开中心日志工作簿，按Alt+F11打开VBA编辑器，插入一个新模块，把代码粘贴进去。
2. 确保保存路径对应的文件夹已经存在，否则会报错。
3. 如果源文件是.xls格式，代码会自动匹配保存格式，无需额外修改。
4. 首次运行前建议先备份中心日志文件，避免误操作。

内容的提问来源于stack exchange，提问作者Jaynee