（含附件重开贴） 请教各位，有一汇总明细表，要指自动拆分并汇总求和。具体见内容

南柯梦否

总表有10000行数据，现在为了方便打印，要把它拆分成每50行为一个工作表（不是工作薄哦，当然如果实在不行，工作薄也行）需带表头，并对拆分后的表进行汇总求和。表格格式如图

因为数据较多，附件里仅截取了部分方便上传。想要的效果：
将总数据按排列次序拆分成每50行一个工作表，需要有表头，同时对拆分后的表格汇总求和。而且，拆分生成的表格 需要保持格式，主要是时间和数值不能乱。

之前有位大侠帮忙弄成拆分成工作薄，但是在求和汇总那里，所得的数据永远都是母表里的1-50行的和。。。其代码如下：
Sub aa()
Dim newbook As Workbook
a = ThisWorkbook.Name
b = ActiveSheet.Name
Application.ScreenUpdating = False
For n = 0 To Range("a65536").End(xlUp).Row \ 49
Set newbook = Workbooks.Add
With newbook
newbook.Activate
Workbooks(a).Sheets(b).Rows("1:1").Copy newbook.Sheets(1).Cells(1, 1)
Workbooks(a).Sheets(b).Rows((49 * n + 2) & ":" & (49 * n + 50)).Copy newbook.Sheets(1).Cells(2, 1)
.Sheets(1).Cells(51, 1) = "合计"
.Sheets(1).Cells(51, 2) = Application.WorksheetFunction.Sum(Range("B2:B50"))
.Sheets(1).Cells(51, 3) = Application.WorksheetFunction.Sum(Range("C2:C50"))
.Sheets(1).Cells(51, 5) = Application.WorksheetFunction.Sum(Range("E2:D50"))
.SaveAs Filename:=ThisWorkbook.Path & "\" & Replace(a, ".xls", "") & n & ".xls"
.Close
End With
Next n
Application.ScreenUpdating = True
End Sub




求大神解答！！非常感谢！！

microyip

ID是从哪里搞出来的？

南柯梦否

microyip 发表于 2016-9-20 11:29
ID是从哪里搞出来的？

晕   这个附件  没有这列。。没关系吧？   要不你加一列空的在前面嘛。。。再传附件都在后面了。。不在1楼了

南柯梦否

这里这里，有完全表头的在这里

su45

如果只是为了打印，没必要拆分成表格的。
你先把行高设置好，保证打印预览中能看到50行，再用代码处理下就能打印了。

microyip

1. Sub 拆分()
   
2.     Dim iSheet As Integer
   
3.     Dim wSH As Worksheet
   
4.     Dim iRows As Integer
   
5.     Dim iAvg As Integer
   
6.     Dim iI As Integer
   
7.    
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10.     With Sheet1
    
11.         For Each wSH In Sheets
    
12.             If wSH.Name <> .Name Then wSH.Delete
    
13.         Next
    
14.         Application.DisplayAlerts = True
    
15.         iRows = Sheet1.UsedRange.Rows.Count - 1
    
16.         iAvg = Int((iRows - 1) / 50) + 1
    
17.         For iI = 1 To iAvg
    
18.             .Copy After:=Sheets(Sheets.Count)
    
19.             ActiveSheet.Name = ((iI - 1) * 50 + 1) & "—" & (iI * 50)
    
20.             If iI < iAvg Then Rows((iI * 50 + 1) & ":" & iRows).Delete shift:=xlUp
    
21.             If iI > 1 Then Rows("2:" & ((iI - 1) * 50)).Delete shift:=xlUp
    
22.             With [A65536].End(xlUp).Offset(1, 0)
    
23.                 .Value = "合计"
    
24.                 With .Offset(0, 2).Resize(1, 4)
    
25.                     .FormulaR1C1 = "=SUM(R[-" & (.Row - 2) & "]C:R[-1]C)"
    
26.                     .Formula = .Value
    
27.                 End With
    
28.                 .Offset(0, 4).ClearContents
    
29.                 [A1:F1].Copy
    
30.                 .Resize(1, 6).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
31.                 Application.CutCopyMode = False
    
32.                 .Resize(1, 2).Merge
    
33.             End With
    
34.         Next
    
35.         .Select
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

microyip

附上附件以供参考

su45

不必拆分为多表，直接打印就OK了。

01.zip (18.51 KB, 下载次数: 10)

2016-9-20 12:49 上传

点击文件名下载附件

南柯梦否

su45 发表于 2016-9-20 12:49
不必拆分为多表，直接打印就OK了。

我把宏点了，在表格里出现了打印虚线，打印打出来的没效果啊？