求助：为拆分后的多工作表表格添加求和公式并套用模板格式

Hi Eric,

刚好之前做过类似的需求，我帮你把现有的拆分宏升级了，完美适配你要的两个功能——自动给拆分后的工作表L到Z列加求和公式，还有套用Template工作表指定行的格式。下面是完整的代码，我会把新增的部分重点解释清楚：

Sub SplitDataAndAddFeatures()
    Dim mainSheet As Worksheet
    Dim newSheet As Worksheet
    Dim templateSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim uniqueNames As Object
    Dim name As Variant
    Dim formulaCol As Long
    Dim templateRowNum As Long ' 指定Template中要套用格式的行号
    
    ' 初始化基础设置
    Set mainSheet = ThisWorkbook.Worksheets("主数据") ' 替换成你的主数据工作表名称
    Set templateSheet = ThisWorkbook.Worksheets("Template") ' 关联模板工作表
    templateRowNum = 1 ' 这里改成你要套用格式的行号（比如Template的第2行就写2）
    Set uniqueNames = CreateObject("Scripting.Dictionary")
    
    ' 获取主数据的最后一行
    lastRow = mainSheet.Cells(mainSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 收集A列的唯一名称
    For i = 2 To lastRow ' 假设第1行是表头，非表头请修改起始行
        If Not uniqueNames.Exists(mainSheet.Cells(i, "A").Value) Then
            uniqueNames.Add mainSheet.Cells(i, "A").Value, 1
        End If
    Next i
    
    ' 循环创建拆分后的工作表
    For Each name In uniqueNames.Keys
        ' 检查工作表是否已存在，不存在则新建
        On Error Resume Next
        Set newSheet = ThisWorkbook.Worksheets(name)
        If Err.Number <> 0 Then
            Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newSheet.Name = name
        End If
        On Error GoTo 0
        
        ' 清空工作表旧数据
        newSheet.Cells.Clear
        
        ' 复制表头到新工作表
        mainSheet.Rows("1:1").Copy Destination:=newSheet.Rows("1:1")
        
        ' 筛选并复制对应名称的数据
        mainSheet.Range("A1:Z" & lastRow).AutoFilter Field:=1, Criteria1:=name
        mainSheet.Range("A2:Z" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=newSheet.Range("A2")
        mainSheet.AutoFilterMode = False
        
        ' ==== 新增功能1：给L-Z列添加求和公式 ====
        With newSheet
            Dim dataLastRow As Long
            dataLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            
            ' 只有存在数据行时才添加求和公式
            If dataLastRow >= 2 Then
                ' 循环L列（第12列）到Z列（第26列）
                For formulaCol = 12 To 26
                    .Cells(dataLastRow + 1, formulaCol).Formula = "=SUM(" & .Range(.Cells(2, formulaCol), .Cells(dataLastRow, formulaCol)).Address & ")"
                    ' 在A列标记"合计"
                    .Cells(dataLastRow + 1, "A").Value = "合计"
                Next formulaCol
            End If
        End With
        
        ' ==== 新增功能2：套用Template指定行的格式 ====
        ' 复制模板指定行的格式到新工作表表头行
        templateSheet.Rows(templateRowNum & ":" & templateRowNum).Copy
        newSheet.Rows("1:1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        ' 可选：如果要把格式应用到整个数据区域+求和行，取消下面一行的注释
        ' newSheet.Range("1:" & dataLastRow + 1).PasteSpecial Paste:=xlPasteFormats
        
        ' 清除剪贴板缓存
        Application.CutCopyMode = False
    Next name
    
    MsgBox "数据拆分及格式设置完成！", vbInformation
End Sub

关键功能细节说明 #

1. 自动添加求和公式 #

• 通过dataLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row精准获取拆分后工作表的最后一行数据位置
• 循环L到Z列，自动生成适配当前列数据范围的求和公式，避免手动调整单元格引用
• 在A列对应行添加"合计"标识，让求和行更直观

2. 套用Template的格式 #

• 你只需修改templateRowNum = 1这个变量，就能指定Template中要复制格式的行（比如要套用第3行格式就改成3）
• 默认是把模板格式套用到新工作表的表头行，如果需要覆盖整个数据区域+求和行，取消注释代码里的对应行即可

注意事项 #

• 请把代码中的"主数据"替换成你实际的主数据工作表名称
• 如果你的主数据表头不是第1行，记得修改收集唯一名称时的起始行（For i = 2 To lastRow中的2改成表头下一行）
• 运行宏前确保Template工作表存在且未被隐藏

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