Excel(VBA)按照某一列拆分成多个工作簿(含标题行与备注行保留、序号列刷新)

参考数据

1、拆分需求：

A.拆分为多个独立工作簿，标题行数不变；

B.每个拆分文件需要包含表头、数据、固定尾部行（如签名、统计行），且要求保留原始格式并重新编号。

2、实现代码：

Sub 筛选拆分()    Dim d As Object, sht As Worksheet, arr, r, i&, m&    Dim Rg As Range, tRow&, tCol&    Dim mysht As Worksheet, LastTwoRows As Range    Dim LastRow As Long, LastCol As Long    Dim savePath As String, ActiveWB As String, s As String    Dim newLastRow As Long, seqLastRow As Long    Dim dataRng As Range, originalTitleRowCount As Long    Set d = CreateObject("scripting.dictionary")    Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)    If Rg Is Nothing Then Exit Sub    tCol = Rg.Column    tRow = Val(Application.InputBox("请输入总表标题行的行数？" & vbCrLf & _              "（例如标题占第1行则输入1，占前2行则输入2）", Title:="标题行数"))    If tRow <= 0 Then MsgBox "标题行数必须大于0，程序退出。": Exit Sub    Call disAppSet(False)    ' 创建保存文件夹    savePath = ThisWorkbook.Path & "\拆分" & Format(Now, "yyyymmdd_hhmmss")    If Dir(savePath, vbDirectory) = "" Then MkDir savePath    If Right(savePath, 1) <> "\" Then savePath = savePath & "\"    ' 取消筛选    If ActiveSheet.FilterMode Then ActiveSheet.Cells.AutoFilter    ActiveWB = ActiveWorkbook.Name    Set mysht = ActiveSheet    ' 获取最后行/列    LastRow = mysht.Cells.Find("*", , , , 1, 2).Row    LastCol = mysht.Cells.Find("*", , , , 2, 2).Column    ' 保存最后两行（含格式）    If LastRow >= 2 Then        Set LastTwoRows = mysht.Range(mysht.Cells(LastRow - 1, 1), mysht.Cells(LastRow, LastCol))    End If    ' 数据区域：从第1行到倒数第3行（排除最后两行）    Set dataRng = mysht.Range(mysht.Cells(1, 1), mysht.Cells(LastRow - 2, LastCol))    ' 收集拆分依据（从标题行下一行开始，到数据区最后一行）    For i = tRow + 1 To LastRow - 2        s = Trim(mysht.Cells(i, tCol).Value)        If s <> "" Then d(s) = ""    Next i    If d.Count = 0 Then MsgBox "没有找到有效的拆分依据！": Exit Sub    m = 0    For Each r In d.keys        ' 1. 新建工作表，并复制完整数据区域（含所有格式）        Set sht = Sheets.Add(After:=Sheets(Sheets.Count))        dataRng.Copy        With sht.Range("A1")            .PasteSpecial xlPasteAll          ' 粘贴全部（值、公式、格式）            .PasteSpecial xlPasteColumnWidths ' 粘贴列宽        End With        ' 逐行复制行高        For i = 1 To dataRng.Rows.Count            sht.Rows(i).RowHeight = dataRng.Rows(i).RowHeight        Next i        Application.CutCopyMode = False        ' 2. 删除不符合当前拆分条件的行（保留标题行）        sht.Activate        With sht.UsedRange            ' 对拆分依据列进行筛选，筛选出不等于 r 的行            .AutoFilter Field:=tCol, Criteria1:="<>" & r            Dim delRng As Range            On Error Resume Next            ' 跳过标题行（前tRow行），获取可见行区域            Set delRng = .Offset(tRow, 0).Resize(.Rows.Count - tRow, 1).SpecialCells(xlCellTypeVisible).EntireRow            On Error GoTo 0            If Not delRng Is Nothing Then delRng.Delete Shift:=xlUp            .AutoFilter        End With        ' ===== 3. 修改标题行的第二行为拆分依据名称 =====        Dim targetRow As Long        If tRow >= 2 Then            ' 原标题已有两行或以上，直接修改第二行（即第2行）            targetRow = 2            ' 假设拆分依据填写在A列（或合并单元格），可根据需要调整            sht.Cells(targetRow, 1).Value = "拆分依据：" & r            ' 可选：设置字体加粗、居中            With sht.Cells(targetRow, 1)                .Font.Bold = True                .HorizontalAlignment = xlCenter            End With            ' 如果该单元格属于合并区域，需要处理合并区域的值            If sht.Cells(targetRow, 1).MergeCells Then                Dim mergeArea As Range                Set mergeArea = sht.Cells(targetRow, 1).MergeArea                mergeArea.Value = "拆分依据：" & r                mergeArea.HorizontalAlignment = xlCenter                mergeArea.Font.Bold = True            End If        Else            ' tRow = 1，只有一行标题，需要在标题行下方插入一行作为第二行            targetRow = tRow + 1   ' 即第2行            sht.Rows(targetRow).Insert Shift:=xlDown            ' 复制上一行（原标题行）的格式到新行            sht.Rows(tRow).Copy            sht.Rows(targetRow).PasteSpecial xlPasteFormats            Application.CutCopyMode = False            ' 填入拆分依据，假设合并第一行所有列或只填A列            sht.Cells(targetRow, 1).Value = "拆分依据：" & r            sht.Cells(targetRow, 1).Font.Bold = True            sht.Cells(targetRow, 1).HorizontalAlignment = xlCenter            ' 如果原标题行有合并单元格，则新插入的行同样合并            If sht.Rows(tRow).Cells(1).MergeCells Then                Dim originalMerge As Range                Set originalMerge = sht.Rows(tRow).Cells(1).MergeArea                sht.Range(sht.Cells(targetRow, originalMerge.Column), sht.Cells(targetRow, originalMerge.Column + originalMerge.Columns.Count - 1)).Merge            End If        End If        ' 4. 粘贴最后两行（保留格式）到子表末尾        If Not LastTwoRows Is Nothing Then            newLastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row            LastTwoRows.Copy            sht.Cells(newLastRow + 1, 1).PasteSpecial xlPasteAll            ' 恢复最后两行的行高            For i = 1 To LastTwoRows.Rows.Count                sht.Rows(newLastRow + i).RowHeight = LastTwoRows.Rows(i).RowHeight            Next i            Application.CutCopyMode = False        End If        ' 5. 重置序号列（假设序号在第1列A列，从标题行下一行开始，且不影响最后两行）        seqLastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row        Dim startSeqRow As Long        startSeqRow = tRow + 1   ' 标题行下一行开始编号        ' 如果 tRow=1 且我们插入了第二行，则起始行要再下移一行        If tRow = 1 Then startSeqRow = tRow + 2        If seqLastRow >= startSeqRow Then            For i = startSeqRow To seqLastRow - 2   ' 排除最后两行                sht.Cells(i, 1).Value = i - startSeqRow + 1            Next i        End If        ' 6. 移动工作表到新工作簿并保存        sht.Move        ' 处理文件名非法字符        Dim fname As String        fname = r        fname = Replace(fname, "/", "-")        fname = Replace(fname, "\", "-")        fname = Replace(fname, ":", "-")        fname = Replace(fname, "*", "-")        fname = Replace(fname, "?", "-")        fname = Replace(fname, Chr(34), "-")        fname = Replace(fname, "<", "-")        fname = Replace(fname, ">", "-")        fname = Replace(fname, "|", "-")        ActiveWorkbook.SaveAs Filename:=savePath & fname & ".xlsx"        ActiveWorkbook.Worksheets(1).Name = "数据"        ActiveWorkbook.Close True        Workbooks(ActiveWB).Activate        m = m + 1    Next r    ' 恢复原始状态    If mysht.FilterMode Then mysht.Cells.AutoFilter    Call disAppSet(True)    MsgBox "完成! 拆分文件数: " & m & vbCrLf & "保存位置: " & savePathEnd SubSub disAppSet(flag As Boolean)    With Application        .ScreenUpdating = flag        .DisplayAlerts = flag        .AskToUpdateLinks = flag        If flag Then .Calculation = xlCalculationAutomatic Else .Calculation = xlCalculationManual    End WithEnd Sub

3、实现效果

选择拆分依据列：用户通过输入框选择某一列作为拆分标准（如“部门”“地区”等）。

指定标题行数：用户输入总表标题所占的行数（例如第1行是标题则输入1，前2行是标题则输入2）。

自动创建保存文件夹：在原始工作簿所在路径下新建“拆分_时间戳”文件夹，用于存放拆分后的文件。

按唯一值拆分数据：遍历除标题行和末尾两行之外的所有行，收集拆分依据列的唯一值；对每个唯一值：

新建工作表，复制完整的数据区域（包含格式、列宽、行高）。

删除不符合条件的行（保留标题行及符合当前拆分值的行）。

修改标题：在原有标题行基础上，添加一行显示“拆分依据：xxx”的说明行。

保留原表最后两行：将原始工作表末尾的两行（通常为汇总或备注行）完整复制到新表的末尾。

重置序号列：假设A列为序号，从标题行的下一行开始重新编号（排除最后两行）。

移动工作表到新工作簿：将处理好的工作表移出当前工作簿，保存为独立的 .xlsx 文件，文件名使用拆分值（非法字符自动替换为 -）。

4、相关步骤：

5、拆分结束提示：

6、拆分结果：

注意事项

拆分依据列不能为空，否则跳过。
序号列必须位于第1列（A列），否则需要修改代码中的列索引。
拆分值包含特殊字符（如 /、* 等）会自动替换为 -，避免文件名非法。
生成的子工作簿仅包含一个名为“数据”的工作表。

不足：

第二行名称命名多了内容“拆分依据：”，需要处理掉