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

swabe

1. 
   
2. Sub t()
   
3.     Dim arr
   
4.     Dim arrtmp()
   
5.     Dim i&, j&, m&, y&
   
6.     Dim t
   
7. 
   
8.     t = Timer
   
9.     y = Range("A65536").End(xlUp).Row
   
10. 
    
11.     ReDim arrtmp(1 To y, 1 To 3)
    
12.     arr = Range("A1:C" & y)
    
13.     j = 1
    
14.     For i = 1 To y
    
15.         If arr(i, 1) <> "" Then
    
16.             arrtmp(j, 1) = arrtmp(j, 1) + arr(i, 1)
    
17.             arrtmp(j, 2) = arrtmp(j, 2) + arr(i, 2)
    
18.             arrtmp(j, 3) = arrtmp(j, 3) + arr(i, 3)
    
19.             m = m + 1
    
20.         Else
    
21.             j = j + m + 1
    
22.             m = 0
    
23.         End If
    
24.     Next
    
25.     Range("e1").Resize(y, 3) = arrtmp
    
26. MsgBox Timer - t
    
27. End Sub
    

复制代码

有点慢，等着看看各位老师的高招！

liuts

60000数据的模拟附件-liuts.rar (522.62 KB, 下载次数: 6)

2011-12-12 15:12 上传

点击文件名下载附件

snowangel007

菜鸟试试                    

Sub test()
    Dim arr, i, j, n, tttt
    tttt = Timer
    arr = ActiveSheet.UsedRange
    For i = 1 To UBound(arr)
        If i = UBound(arr) Then Exit For
        If Not IsEmpty(arr(i, 1)) Then
           n = i
           Do While Not IsEmpty(arr(i + 1, 1))
                For j = 1 To UBound(arr, 2)
                    arr(n, j) = arr(n, j) + arr(i + 1, j)
                    arr(i + 1, j) = ""
                Next
                i = i + 1
               If i = UBound(arr) Then Exit Do
            Loop
        End If
    Next
    Range("f1").Resize(UBound(arr), UBound(arr, 2)) = arr
    MsgBox Timer - tttt
End Sub

sunjing-zxl

1. Sub aa()
   
2.     Dim arr, arr1(), n As Long, m As Long, i As Long, j As Long
   
3.     Range("F1:H65536").ClearContents
   
4.     n = [A65536].End(xlUp).Row + 1
   
5.     arr = Range("A1:C" & n)
   
6.     ReDim arr1(1 To n, 1 To 3)
   
7.     m = 1
   
8.     For i = 1 To n
   
9.         If arr(i, 1) = "" Then
   
10.             For j = m To i
    
11.                 arr1(m, 1) = IIf(arr1(m, 1) + arr(j, 1) = 0, "", arr1(m, 1) + arr(j, 1))
    
12.                 arr1(m, 2) = IIf(arr1(m, 2) + arr(j, 2) = 0, "", arr1(m, 2) + arr(j, 2))
    
13.                 arr1(m, 3) = IIf(arr1(m, 3) + arr(j, 3) = 0, "", arr1(m, 3) + arr(j, 3))
    
14.             Next j
    
15.             m = i + 1
    
16.         End If
    
17.     Next i
    
18.     Range("F1:H" & n) = arr1
    
19. End Sub
    

复制代码

我来抽个热闹

windimi007

兰版好想讲过：IsEmpty比=""速度要快点，然后稍微再改动一下代码的位置，速度好像又能提高那么一点点{:3512:}

1. Sub aa()
   
2.     Dim arr
   
3.     Dim i&, j&, k%, t!
   
4.     t = Timer
   
5.     arr = Range("A1:C" & Cells(Rows.Count, 1).End(3).Row + 1)
   
6.     For i = 1 To UBound(arr) - 1
   
7.         If IsEmpty(arr(i, 1)) Then GoTo 7
   
8.         j = i
   
9.         Do Until IsEmpty(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.     MsgBox Timer - t
    
20. End Sub

复制代码

ldxhzy

在自己的电脑上测试，用时约 1 秒，请老师审核。

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Dim T As Double  '开始时间
    T = Now
    Dim I As Long, J As Long, H As Long
   
    Dim MySum(1 To 3) As Long
    Dim MyData()
    H = ActiveSheet.UsedRange.Rows.Count
    ReDim MyData(1 To H, 1 To 3)
    MyData() = ActiveSheet.Range(Cells(1, 1), Cells(H, 3)).Value
    J = 1
    I = 1
    Do
        If IsEmpty(MyData(I, 1)) Then
            Range("F" & J & ":H" & J) = MySum
            MySum(1) = 0
            MySum(2) = 0
            MySum(3) = 0
            Do
                I = I + 1
            Loop While IsEmpty(MyData(I, 1))
            J = I         '记下下次汇总数所在行
        End If
        MySum(1) = MyData(I, 1) + MySum(1)
        MySum(2) = MyData(I, 2) + MySum(2)
        MySum(3) = MyData(I, 3) + MySum(3)
      
        If I = H Then   '到了最后一行
            Range("F" & J & ":H" & J) = MySum
        End If
         I = I + 1
    Loop While I <= H
    Application.ScreenUpdating = True
    MsgBox "用时（秒数）：" & (Hour(Now) * 3600 + Minute(Now) * 60 + Second(Now) - Hour(T) * 3600 - Minute(T) * 60 - Second(T))
End Sub

wcymiss

开贴啦。我的代码如下：

1. Sub wcymiss()
   
2.     Dim I&, arr, brr(), J&, n&
   
3.     arr = Range("a1:c" & Cells(Rows.Count, 1).End(3).Row + 1)
   
4.     ReDim brr(1 To UBound(arr), 1 To 3)
   
5.     For J = 1 To 3
   
6.         brr(1, J) = arr(1, J)
   
7.     Next
   
8.     n = 1
   
9.     For I = 2 To UBound(arr)
   
10.         If arr(I, 1) <> "" Then
    
11.             If n = 0 Then n = I
    
12.             For J = 1 To 3
    
13.                 brr(n, J) = brr(n, J) + arr(I, J)
    
14.             Next
    
15.         Else
    
16.             n = 0
    
17.         End If
    
18.     Next
    
19.     Range("f1:h" & UBound(brr)) = brr
    
20.     Range("f:h").ClearContents
    
21. End Sub

复制代码

wcymiss

各楼层代码汇总的附件： 答案汇总.rar (411.95 KB, 下载次数: 49)

2011-12-13 13:23 上传

点击文件名下载附件

为方便统一测算速度，对代码部分地方做了小的改动。

大家可以测测，谁的代码较快？

我的机器上测出来是8楼、9楼、11楼最快。但所有代码都是在1秒以内的，差别非常小。

snowangel007

学习了                        

wcymiss

题目虽小，不过也让我学到很多。
比如，用isempty比用="" 判断，速度上要效率很多。
     直接写三行代码比用for  j=1 to  3  这个循环速度也较快。

其他的就等开课后由花花老师讲解给大家听吧