练习（一）12.11：求和【已开贴】

wcymiss

快开课了，是不是来个热身？



题目说明：
1、如图，A、B、C列均为数字或空，数据从A1开始，要求对以空行分隔的区域按列分别求和。
2、每行要么都是数字，要么都是空。不会出现空和数字的混合。
3、空行不一定只空一行。
3、结果放在F:H列的每块连续数字区域的第一行里。如模拟效果所示。
4、数据很多，请勿直接引用"A1:C7"。
5、不得在循环内出现单元格操作。
Book11.rar (2.89 KB, 下载次数: 79)

2011-12-11 21:16 上传

点击文件名下载附件

出题目的：集思广益，想看看大家的方法。自我感觉我的方法不是很好。

注：限制在循环内出现单元格操作，是为了代码的效率。如果你有循环操作单元格但同时是非常效率的方法，也是可行的。
数据很多，想象有几万甚至几十万行。

再上个60000数据的模拟附件，以便测试代码效率。（死机不管哈）

60000数据的模拟附件.rar (391.82 KB, 下载次数: 902)

2011-12-11 22:51 上传

点击文件名下载附件

——————————————————————————————————————
18楼有各楼层代码汇总附件

Benol

试一个

1. Sub Xsum()
   
2. Dim rng As Range, area As Range
   
3. Dim arr
   
4. Dim i As Long, cnt As Long, j As Integer
   
5. Set rng = Range(Cells(1, 1), Cells([C65536].End(3).Row, 3))
   
6. arr = rng.Cells
   
7. For i = UBound(arr) To 2 Step -1
   
8.   If arr(i - 1, 1) <> "" Then
   
9.    For j = 1 To 3
   
10.     arr(i - 1, j) = arr(i - 1, j) + arr(i, j)
    
11.     arr(i, j) = ""
    
12.    Next
    
13.   End If
    
14.   Next
    
15.   rng.Offset(0, 5) = arr
    
16. End Sub

复制代码

Benol

突然发现吴姐为我开了后门了，哈哈，那就再发一个

1. 
   
2. Sub Xsum()
   
3. Dim rng As Range, area As Range
   
4. Set rng = Range("A:C").SpecialCells(xlCellTypeConstants, 1)
   
5. For Each area In rng.Areas
   
6.   arr = area.Cells
   
7.   For i = 1 To 3
   
8.   arr(1, i) = WorksheetFunction.Sum(Application.Index(arr, , i))
   
9.   area.Rows(1).Offset(0, 5) = arr
   
10.   Next
    
11. Next
    
12. End Sub
    

复制代码

ps: 经吴姐启发，发现SpecialCells方法有局限。
1. 数据量大的时候，效率很低。不论是手工还是VBA，它都很慢。
2. 以上面代码为例，rng源于SpecialCells方法，当rng.areas.count>=8192 (注：8192=2^13）时，将不能返回正确结果。同样的，即便是手工操作定位功能，也不能一次性定位8192个及以上area（姑且就叫area，你们知道我所指，嘿嘿）

乐满地

Book11.zip (13.46 KB, 下载次数: 10)

2011-12-11 22:47 上传

点击文件名下载附件

Sub huizong()
    Dim arr, brr
    Dim x As Integer, y As Integer, k As Integer
    Dim r, c
    r = [a65536].End(xlUp).Row
    c = Range("1:1").Find("").Column - 1
    arr = Range("a1", Cells(r, c))
    ReDim brr(1 To r, 1 To c)
    k = 1
    For x = 1 To r
        For y = 1 To c
            brr(k, y) = brr(k, y) + arr(x, y)
        Next y
        If arr(x, 1) = "" Then k = x + 1
    Next x
    Range("f1").Resize(7, 3) = brr
End Sub

乐满地

Book11.zip (76.84 KB, 下载次数: 2)

2011-12-11 23:35 上传

点击文件名下载附件

Sub huizong()
    Dim arr, brr
    Dim x As Long, k As Long
    Dim r
    r = [a65536].End(xlUp).Row
    arr = Range("a1", Cells(r, 3))
    ReDim brr(1 To r, 1 To 3)
    k = 1
    For x = 1 To r
        If arr(x, 1) <> "" Then
            For y = 1 To 3
                brr(k, y) = brr(k, y) + arr(x, y)
            Next y
        End If
        If arr(x, 1) = "" Then k = x + 1
    Next x
    Range("f1").Resize(r, 3) = brr
End Sub

下次直接把代码贴出来就行啦-，附件不用上--------wcymiss

csmctjg

1. 
   
2. Sub 习题()
   
3. Dim i As Long, j As Byte, m As Long, arr, brr(1 To 60000, 1 To 3)
   
4. arr = Range("A1: C" & [A65536].End(xlUp).Row + 1)
   
5. For i = 1 To UBound(arr)
   
6.     m = i
   
7.     While arr(i, 1) <> ""
   
8.         For j = 1 To 3
   
9.             brr(m, j) = brr(m, j) + arr(i, j)
   
10.         Next j
    
11.         i = i + 1
    
12.     Wend
    
13. Next i
    
14. [F1].Resize(UBound(arr), 3) = brr
    
15. End Sub
    

复制代码

9lee

1. 
   
2. Sub lee()
   
3. Dim arr, brr()
   
4. arr = ActiveSheet.UsedRange
   
5. ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
   
6. 
   
7. For i = 1 To UBound(arr)
   
8.     If arr(i, 1) <> "" Then
   
9.         For j = 1 To UBound(arr, 2)
   
10.             brr(x + 1, j) = brr(x + 1, j) + arr(i, j)
    
11.         Next j
    
12.     Else
    
13.         x = i
    
14.     End If
    
15. Next i
    
16. 
    
17. ActiveSheet.[f1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
18. 
    
19. End Sub

复制代码

liuguansky

1. Sub huizong()
   
2.     Dim arr, brr(), x&, k&, r&, t
   
3.     t = Timer
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     arr = Range("a1", Cells(r, 3))
   
6.     ReDim brr(1 To r, 1 To 3)
   
7.     k = 1
   
8.     For x = 1 To r
   
9.         If Len(arr(x, 1)) Then
   
10.             brr(k, 1) = brr(k, 1) + arr(x, 1)
    
11.             brr(k, 2) = brr(k, 2) + arr(x, 2)
    
12.             brr(k, 3) = brr(k, 3) + arr(x, 3)
    
13.             Else: k = x + 1
    
14.         End If
    
15.     Next x
    
16.     Range("f:h").Clear
    
17.     Range("f1").Resize(r, 3) = brr
    
18.     MsgBox Timer - t
    
19. End Sub

复制代码

如果我写的话，和乐满地的思路应该一样。

JLxiangwei

Sub text()
    Dim arr, arr1(1 To 60000, 1 To 3), x As Long, y As Long, z As Long, m As Long, t
    t = Timer
    x = Range("a65536").End(xlUp).Row
    arr = Range("a1:c" & x)
    m = 1
    For y = 1 To x
        If arr(y, 1) <> "" Then
            For z = 1 To 3
                arr1(m, z) = arr1(m, z) + arr(y, z)
            Next z
        Else
            m = y + 1
        End If
    Next y
    Range("f1").Resize(60000, 3) = arr1
    t = Timer - t
    MsgBox t
End Sub

windimi007

交练习喽！{:3512:}

1. 
   
2. Sub aa()
   
3.     Dim arr
   
4.     Dim i&, j&, k%
   
5.     arr = Range("A1:C" & Cells(Rows.Count, 1).End(3).Row + 1)
   
6.     For i = 1 To UBound(arr) - 1
   
7.         j = i
   
8.         If arr(i, 1) = "" Then GoTo 7
   
9.         Do Until arr(i + 1, 1) = ""
   
10.             i = i + 1
    
11.             For k = 1 To 3
    
12.                 arr(j, k) = arr(j, k) + arr(i, k)
    
13.                 arr(i, k) = ""
    
14.             Next k
    
15.         Loop
    
16. 7:
    
17.     Next i
    
18.     Range("E1").Resize(UBound(arr), 3) = arr
    
19. End Sub

复制代码