拆分Excel/表格

我这边当前没读到你的实际附件，所以直接给你一个在 Excel 里一键拆分的方法。跑完就是最终结果：按部门拆成独立文件，保留单行表头，保留格式颜色，只保留值。

操作步骤

1. 打开 2024年10月报销明细.xlsx，点一下报销数据所在的工作表。
2. 按 Alt + F11 打开 VBA 编辑器。
3. 左侧工程栏里，右键你的 Excel 文件 → 插入 → 模块。
4. 把下面整段代码复制粘贴进去。
5. 光标放在代码里，按 F5 运行。

VBA 代码

Sub SplitByDept()
    Dim srcBook As Workbook
    Dim srcSheet As Worksheet
    Dim deptCol As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long
    Dim deptKey As String
    Dim dict As Object
    Dim key As Variant
    Dim outDir As String
    Dim newBook As Workbook
    Dim safeName As String
    Dim vDeptCol As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set srcBook = ThisWorkbook
    Set srcSheet = srcBook.ActiveSheet

    If Len(srcBook.Path) = 0 Then
        MsgBox "请先保存源文件到本地后，再运行本宏。", vbExclamation
        GoTo 退出
    End If

    ' 找“部门”列：先精确匹配，再模糊匹配包含“部门”
    vDeptCol = Application.Match("部门", srcSheet.Rows(1), 0)
    If IsError(vDeptCol) Then
        vDeptCol = Application.Match("*部门*", srcSheet.Rows(1), 0)
    End If
    If IsError(vDeptCol) Then
        MsgBox "第一行没有找到“部门”列，请检查标题。", vbCritical
        GoTo 退出
    End If
    deptCol = CLng(vDeptCol)

    lastRow = srcSheet.Cells(srcSheet.Rows.Count, deptCol).End(xlUp).Row
    lastCol = srcSheet.Cells(1, srcSheet.Columns.Count).End(xlToLeft).Column

    ' 收集所有不重复部门
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare

    For i = 2 To lastRow
        If Not IsEmpty(srcSheet.Cells(i, deptCol).Value) Then
            deptKey = CStr(srcSheet.Cells(i, deptCol).Value)
            If Len(Trim(deptKey)) > 0 And Not dict.Exists(deptKey) Then
                dict.Add deptKey, 1
            End If
        End If
    Next i

    If dict.Count = 0 Then
        MsgBox "部门列没有数据。", vbExclamation
        GoTo 退出
    End If

    ' 输出文件夹
    outDir = srcBook.Path & Application.PathSeparator & "拆分结果"
    If Dir(outDir, vbDirectory) = "" Then MkDir outDir

    ' 清掉已有筛选
    If srcSheet.FilterMode Then srcSheet.ShowAllData
    If srcSheet.AutoFilterMode Then srcSheet.AutoFilterMode = False

    ' 按部门逐个筛选、复制、保存
    For Each key In dict.Keys
        srcSheet.Range("A1").Resize(lastRow, lastCol).AutoFilter Field:=deptCol, Criteria1:=key

        Set newBook = Workbooks.Add(xlWBATWorksheet)

        srcSheet.Range("A1").Resize(lastRow, lastCol).SpecialCells(xlCellTypeVisible).Copy
        With newBook.Worksheets(1).Range("A1")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            .PasteSpecial xlPasteColumnWidths
        End With

        newBook.Worksheets(1).Name = "报销明细"

        safeName = MakeFileNameSafe(CStr(key))
        newBook.SaveAs Filename:=outDir & Application.PathSeparator & "2024年10月报销明细-" & safeName & ".xlsx", FileFormat:=51
        newBook.Close False

        Application.CutCopyMode = False
        If srcSheet.FilterMode Then srcSheet.ShowAllData
    Next key

    If srcSheet.FilterMode Then srcSheet.ShowAllData
    If srcSheet.AutoFilterMode Then srcSheet.AutoFilterMode = False

    MsgBox "拆分完成，文件在：" & outDir, vbInformation

退出:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Function MakeFileNameSafe(ByVal s As String) As String
    Dim bad As Variant
    Dim i As Long

    bad = Array("/", "\", ":", "*", "?", """", "<", ">", "|")
    For i = LBound(bad) To UBound(bad)
        s = Replace(s, bad(i), "_")
    Next i

    MakeFileNameSafe = Trim(s)
End Funct