请教各位老师，根据总表按日期拆分明细表

assgh1

目前表里已经有拆分明细的代码，但拆分的明细没有合计功能，想在最后一列增加合计数，还有明细表的抬头也要增加，请各位老师帮帮忙！
Sub 拆分为工作表()
Application.ScreenUpdating = False '防止屏幕抖动,屏幕刷新禁止
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name <> "初始表格" Then sh.Delete
Next
Sheets("初始表格").Range("A3:I" & Sheets("初始表格").Range("c65536").End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlAscending
n = 3
    With ThisWorkbook.Sheets("初始表格")
        For Each b In .Range("c3:c" & .Range("c65536").End(xlUp).Row)
            u = b.Row
            If b <> b.Offset(1, 0) Then
            Sheets.Add After:=Sheets(Sheets.Count)

                .Rows("2").Copy Sheets(Sheets.Count).Range("a1")

                .Rows(n & ":" & u).Copy Sheets(Sheets.Count).Range("a2")

                    Sheets(Sheets.Count).Name = Format(b, "m月-d日")
                 n = u + 1
            End If
        Next
    End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

assgh1

是每个明细表最下面一行，增加合计

cqlpjxx

解决办法:
1.先在初始表格内增加合计列
2.  .Rows("2").Copy Sheets(Sheets.Count).Range("a1")
     .Rows(n & ":" & u).Copy Sheets(Sheets.Count).Range("a2")
改为:  .Rows("1:2").Copy Sheets(Sheets.Count).Range("a1")
         .Rows(n & ":" & u).Copy Sheets(Sheets.Count).Range("a3")

lsc900707

assgh1 发表于 2017-4-16 11:51
是每个明细表最下面一行，增加合计

参考：
见证成长历程---2017年我的答疑解难代码汇总
http://club.excelhome.net/thread-1322460-1-1.html
(出处: ExcelHome技术论坛)
第66楼拆分并增加分表的平均数代码

lsc900707

assgh1 发表于 2017-4-16 11:51
是每个明细表最下面一行，增加合计

Sub 拆分为工作表()
Application.ScreenUpdating = False '防止屏幕抖动,屏幕刷新禁止
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name <> "初始表格" Then sh.Delete
Next
Sheets("初始表格").Range("A3:I" & Sheets("初始表格").Range("c65536").End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlAscending
n = 3
    With ThisWorkbook.Sheets("初始表格")
        For Each b In .Range("c3:c" & .Range("c65536").End(xlUp).Row)
            u = b.Row
            If b <> b.Offset(1, 0) Then
            Sheets.Add after:=Sheets(Sheets.Count)
            
                .Rows("1:2").Copy Sheets(Sheets.Count).Range("a1")
   
                .Rows(n & ":" & u).Copy Sheets(Sheets.Count).Range("a3")
              
                    Sheets(Sheets.Count).Name = Format(b, "m月-d日")
                 n = u + 1
            End If
        Next
    End With
    For Each sh In Sheets
        If sh.Name <> "初始表格" Then
           With sh
              k = .Range("a65536").End(xlUp).Row
              arr = .UsedRange
              For i = 3 To UBound(arr)
                  For j = 4 To UBound(arr, 2)
                     If IsNumeric(.Cells(i, j)) Then
                         .Cells(k + 1, 1) = "合计"
                         .Cells(k + 1, j) = Application.Sum(Application.Index(arr, , j))
                     End If
                  Next
              Next
            End With
        End If
    Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

assgh1

lsc900707 发表于 2017-4-16 13:05
Sub 拆分为工作表()
Application.ScreenUpdating = False '防止屏幕抖动,屏幕刷新禁止
Application.Dis ...

可以帮我这个表格弄一下吗，我套不上

lsc900707

assgh1 发表于 2017-4-19 21:59
可以帮我这个表格弄一下吗，我套不上

你改了工作表格式，当然套不上。明天弄吧，今天太晚了。

assgh1

lsc900707 发表于 2017-4-19 22:33
你改了工作表格式，当然套不上。明天弄吧，今天太晚了。

感谢！！！

lsc900707

assgh1 发表于 2017-4-19 23:27
感谢！！！

1. Sub 拆分为工作表()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. For Each sh In Worksheets
   
5. If sh.Name <> "模板" And sh.Name <> "Sheet1" Then sh.Delete
   
6. Next
   
7. Sheet1.Range("A2:G" & Sheet1.Range("B65536").End(xlUp).Row).Sort Key1:=Range("B1"), Order1:=xlAscending
   
8. n = 2
   
9.     With ThisWorkbook.Sheets("Sheet1")
   
10.         For Each b In .Range("B2:B" & .Range("B65536").End(xlUp).Row)
    
11.             u = b.Row
    
12.             If b <> b.Offset(1, 0) Then
    
13.             Sheets("模板").Copy After:=Sheets(Worksheets.Count)
    
14.                 .Rows(n & ":" & u).Copy Sheets(Sheets.Count).Range("a4")
    
15.                 Sheets(Sheets.Count).Name = Format(b, "m月d日")
    
16.                  n = u + 1
    
17.             End If
    
18.         Next
    
19.     End With
    
20.     For Each sh In Sheets
    
21.         If sh.Name <> "模板" And sh.Name <> "Sheet1" Then
    
22.            With sh
    
23.               k = .Range("a65536").End(xlUp).Row
    
24.               arr = .UsedRange
    
25.               For i = 4 To UBound(arr)
    
26.                   For j = 5 To UBound(arr, 2)
    
27.                      If IsNumeric(.Cells(i, j)) Then
    
28.                          .Cells(k - 3, j) = Application.Sum(Application.Index(arr, , j))
    
29.                      End If
    
30.                   Next
    
31.               Next
    
32.             End With
    
33.         End If
    
34.     Next
    
35. Application.ScreenUpdating = True
    
36. Application.DisplayAlerts = True
    
37. End Sub

复制代码

lsc900707

代码修改好了，正在审核中，先把附件上传供参考。