[已解决]所有表页自动产生合计栏

lujianwkx

工作中有许多表格只有明细没有汇总,需逐表将所有表页的最后一栏增加合计栏,对所有数值型数据进行合计.最好将合计栏用黄色底纹标注.哪位能帮我用VBA解决?谢谢.附件为样表

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-6-29 13:11

我就不信了，附件请测试，不用逐个选择工作表，速度有保证。
全部生成公式！
格式你在工作表里一次设置好不就可以了。

1. Private Sub CommandButton1_Click()
   
2. t = Timer
   
3. Dim arr, i&, j%, k&, sh As Byte
   
4. For i = 1 To 5
   
5.   arr = Sheets(i).Range(Sheets(i).Cells(1, 1), Sheets(i).Cells(Sheets(i).[a65536].End(3).Row + 1, Sheets(i).[iv1].End(1).Column + 1))
   
6.   arr(UBound(arr), 1) = "Count": arr(1, UBound(arr, 2)) = "Count"
   
7.   For j = 2 To UBound(arr, 2) - 1
   
8.     arr(UBound(arr), j) = "=sum(" & Chr(64 + j) & "2:" & Chr(64 + j) & UBound(arr) - 1 & ")"
   
9.   Next j
   
10.   For k = 2 To UBound(arr)
    
11.     arr(k, UBound(arr, 2)) = "=sum(B" & k & ":" & Chr(64 + UBound(arr, 2) - 1) & k & ")"
    
12.   Next k
    
13.   Sheets(i).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
14.   Sheets(i).Range(Sheets(i).Cells(UBound(arr), 1), Sheets(i).Cells(UBound(arr), UBound(arr, 2))).Interior.ColorIndex = 6
    
15.   Sheets(i).Range(Sheets(i).Cells(1, UBound(arr, 2)), Sheets(i).Cells(UBound(arr), UBound(arr, 2))).Interior.ColorIndex = 6
    
16. Next i
    
17. MsgBox Timer - t & "Sec"
    
18. End Sub

复制代码

跳转到最佳答案楼层

lyf7276

你看是这样子的吗？ 表样.zip (24.2 KB, 下载次数: 10)

2013-6-26 16:59 上传

点击文件名下载附件

大灰狼1976

附件请测试，横向纵向都有汇总涂色。

1. Private Sub CommandButton1_Click()
   
2. t = Timer
   
3. Dim arr, i&, j%, k&, sh As Byte
   
4. For i = 1 To 5
   
5.   arr = Sheets(i).Range(Sheets(i).Cells(1, 1), Sheets(i).Cells(Sheets(i).[a65536].End(3).Row + 1, Sheets(i).[iv1].End(1).Column + 1))
   
6.   arr(UBound(arr), 1) = "Count": arr(1, UBound(arr, 2)) = "Count"
   
7.   For j = 2 To UBound(arr, 2) - 1
   
8.     arr(UBound(arr), j) = Application.Sum(Application.Index(arr, , j))
   
9.   Next j
   
10.   For k = 2 To UBound(arr)
    
11.     arr(k, UBound(arr, 2)) = Application.Sum(Application.Index(arr, k, 0))
    
12.   Next k
    
13.   Sheets(i).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
14.   Sheets(i).Range(Sheets(i).Cells(UBound(arr), 1), Sheets(i).Cells(UBound(arr), UBound(arr, 2))).Interior.ColorIndex = 6
    
15.   Sheets(i).Range(Sheets(i).Cells(1, UBound(arr, 2)), Sheets(i).Cells(UBound(arr), UBound(arr, 2))).Interior.ColorIndex = 6
    
16. Next i
    
17. MsgBox Timer - t & "Sec"
    
18. End Sub

复制代码

大灰狼1976

速度绝对没问题！

lujianwkx

1楼的已解决,谢谢

lujianwkx

结果正确,可不可以让黄色合计栏显示的不是数值而是SUM公式.这样看起来数据源清楚.合计栏单元格格式为#,##0.00,可以做到吗?谢谢

大灰狼1976

我就不信了，附件请测试，不用逐个选择工作表，速度有保证。
全部生成公式！
格式你在工作表里一次设置好不就可以了。

1. Private Sub CommandButton1_Click()
   
2. t = Timer
   
3. Dim arr, i&, j%, k&, sh As Byte
   
4. For i = 1 To 5
   
5.   arr = Sheets(i).Range(Sheets(i).Cells(1, 1), Sheets(i).Cells(Sheets(i).[a65536].End(3).Row + 1, Sheets(i).[iv1].End(1).Column + 1))
   
6.   arr(UBound(arr), 1) = "Count": arr(1, UBound(arr, 2)) = "Count"
   
7.   For j = 2 To UBound(arr, 2) - 1
   
8.     arr(UBound(arr), j) = "=sum(" & Chr(64 + j) & "2:" & Chr(64 + j) & UBound(arr) - 1 & ")"
   
9.   Next j
   
10.   For k = 2 To UBound(arr)
    
11.     arr(k, UBound(arr, 2)) = "=sum(B" & k & ":" & Chr(64 + UBound(arr, 2) - 1) & k & ")"
    
12.   Next k
    
13.   Sheets(i).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
14.   Sheets(i).Range(Sheets(i).Cells(UBound(arr), 1), Sheets(i).Cells(UBound(arr), UBound(arr, 2))).Interior.ColorIndex = 6
    
15.   Sheets(i).Range(Sheets(i).Cells(1, UBound(arr, 2)), Sheets(i).Cells(UBound(arr), UBound(arr, 2))).Interior.ColorIndex = 6
    
16. Next i
    
17. MsgBox Timer - t & "Sec"
    
18. End Sub

复制代码