请求帮忙优化VBA代码！！！！

xuwenning

主要功能是根据分组值（单元格A1中）计算DATA表中数据（A列）的起始值、结束值、和值、平均值、极差、标准差；
如果单元格A1中的值为1的话结束值、和值、平均值、极差为空，标准差变成移动极差值
自己编写的VBA代码：使用了一维数组、调用了excel功能函数实现
运行是感觉不是太理想1394个数据在分组值为1是用了4秒多的时间，那如果处理1万个数据不是要我等到老吗 ？；

求助斑竹、高手、网友帮助优化一下看看是否还有新的方法（如用字典会否好点）
多的不说了见附件
优化计算求助.rar (47.96 KB, 下载次数: 20)

2010-4-15 09:51 上传

点击文件名下载附件

[ 本帖最后由 xuwenning 于 2010-4-16 09:15 编辑 ]

xuwenning

附上代码
Sub Test()
Dim Rowcount%, Rowcount1%, H%, I%, J%, K%, L%
Dim T
Dim Arr As Variant '
Dim Arr1 As Variant
Dim Tmp
Dim TmpA   '和值
Dim TmpB   '平均值
Dim TmpC   '极差
Dim TmpD   '标准差
Dim TmpE   '起始值
Dim TmpF    '结束值
Dim TmpC1   '最大值
Dim TmpC2   '最小值

Dim rng As Range
Dim Dic As Object

    T = Timer
    Rowcount = Sheets("Data").Range("A65536").End(xlUp).Row '返回Data表中A列的数据最大行
   
    Rowcount1 = Sheets("结果").Range("B65536").End(xlUp).Row '返回结果表中A列的数据最大行
   
    ReDim Arr(Rowcount)
    Erase Arr '初始化
   
    Arr = Sheets("data").Range("A1:A" & Rowcount)
   
    'Sheets("结果").Range("A2:G" & Rowcount).Clear '全部清除
    Sheets("结果").Range("A2:G" & Rowcount1 + 1).ClearContents '清除内容
   
    Tmp = Sheets("结果").Range("A1")
   
    If Rowcount < 2 Or Tmp > Rowcount Then Exit Sub
   
    If Tmp = 0 Or IsNull(Tmp) Or Tmp = "" Then
        MsgBox "A1值不能为空或零"
        Exit Sub
    End If
   
    K = Fix(Rowcount / Tmp)
   
    Debug.Print "K:" & K
    Debug.Print "Rowcout:" & Rowcount
   
    For J = 1 To K
   
        ReDim Arr1(Tmp)
        Erase Arr1 '初始化
        
        L = (J - 1) * Tmp + 1
        If Tmp = 1 Then
            H = J
        Else
            H = J * Tmp
        End If
        Debug.Print "L:" & L
        Debug.Print "H:" & H
   
        
        If Tmp = 1 Then
            
            TmpA = ""
            TmpB = ""
            TmpC = ""
            TmpE = Arr(L, 1)
            
            TmpF = ""
            If J = 1 Then
                TmpD = ""
            Else
                TmpD = Arr(J, 1) - Arr(J - 1, 1)
            End If
            
            Sheets("结果").Range("G" & J + 1) = TmpD  '标准差实际为移动极差
        Else
            Arr1 = Sheets("data").Range("A" & L & ":A" & H)
            TmpA = Application.WorksheetFunction.Sum(Arr1)          '调用EXCEL功能函数求和
            TmpB = Application.WorksheetFunction.Average(Arr1)      '调用EXCEL功能函数求均值
            TmpC1 = Application.WorksheetFunction.Max(Arr1)         '调用EXCEL功能函数求最大值
            TmpC2 = Application.WorksheetFunction.Min(Arr1)         '调用EXCEL功能函数求最小值
            TmpC = TmpC1 - TmpC2                                    '调用EXCEL功能函数求极差
            TmpD = Application.WorksheetFunction.StDev(Arr1)        '调用EXCEL功能函数求标准差
            TmpE = Arr(L, 1)
            TmpF = Arr(H, 1)
            
            Sheets("结果").Range("G" & J + 1) = TmpD  '标准差
        
        End If
        
        Sheets("结果").Range("B" & J + 1) = TmpE  '起始值
        Sheets("结果").Range("C" & J + 1) = TmpF  '结束值
        Sheets("结果").Range("D" & J + 1) = TmpA  '和值
        Sheets("结果").Range("E" & J + 1) = TmpB  '平均值
        Sheets("结果").Range("F" & J + 1) = TmpC  '极差
     Next J
    MsgBox "OK!用时[" & (Timer - T) & "秒]"
     
End Sub

ningyuanchao

Application.ScreenUpdating=False
…………
Application.ScreenUpdating=True
加上这两句，运行时间立马减半。

xuwenning

原帖由 ningyuanchao 于 2010-4-15 10:13 发表
Application.ScreenUpdating=False
…………
Application.ScreenUpdating=True
加上这两句，运行时间立马减半。

谢谢减小了0.5秒


[ 本帖最后由 xuwenning 于 2010-4-15 10:45 编辑 ]

xuwenning

再次请求斑竹帮忙

xuwenning

原帖由 xuwenning 于 2010-4-15 09:51 发表
主要功能是根据分组值（单元格A1中）计算DATA表中数据（A列）的起始值、结束值、和值、平均值、极差、标准差；
如果单元格A1中的值为1的话结束值、和值、平均值、极差为空，标准差变成移动极差值
自己编写的VBA代码 ...

是否描述不足
至今没人帮助？？？？？？？？？？

YZC51

请参考
Sub Test_1()
Dim Rowcount%, Rowcount1%, H%, I%, J%, K%, L%, T
Dim Arr, Arr1, Brr
Dim rng As Range
Application.ScreenUpdating = False
    T = Timer
    Rowcount = Sheets("Data").Range("A65536").End(xlUp).Row    '返回Data表中A列的数据最大行
    Rowcount1 = Sheets("结果").Range("B65536").End(xlUp).Row   '返回结果表中A列的数据最大行
    Arr = Sheets("Data").Range("A1:A" & Rowcount)
    Sheets("结果").Range("A2:G" & Rowcount1 + 1).ClearContents '清除内容
    Tmp = Sheets("结果").Range("A1")
    If Rowcount < 2 Or Tmp > Rowcount Then Exit Sub
    If Tmp = 0 Or IsNull(Tmp) Or Tmp = "" Then
        MsgBox "A1值不能为空或零"
        Exit Sub
    End If
    K = -Int(-Rowcount / Tmp)
    Debug.Print K
    ReDim Brr(1 To K, 1 To 7)
    n = 0
    For J = 1 To UBound(Arr, 1) Step Tmp
        n = n + 1
        Brr(n, 1) = n
        If n > K Then Exit For
        ReDim Arr1(1 To Tmp, 1 To 1)
        If Tmp = 1 Then
            Brr(n, 2) = Arr(J, 1)
            If J > 1 Then Brr(n, 7) = Arr(J, 1) - Arr(J - 1, 1)
        Else
            For I = 1 To Tmp
                Brr(n, 2) = Arr(J, 1)
                If I + J > UBound(Arr, 1) + 1 Then Exit For
                Arr1(I, 1) = Arr(J + I - 1, 1)
            Next I
            If J + Tmp > UBound(Arr, 1) + 1 Then Exit For
            Brr(n, 3) = Arr(J + Tmp - 1, 1)
            Brr(n, 4) = Application.Sum(Arr1)
            Brr(n, 5) = Application.Average(Arr1)
            Brr(n, 6) = Application.Max(Arr1) - Application.Min(Arr1)
            Brr(n, 7) = Application.StDev(Arr1)
        End If
        Erase Arr1 '初始化
    Next J
    [A2].Resize(Rowcount \ Tmp, UBound(Brr, 2)) = Brr
    [H1] = Sheets("结果").Range("B65536").End(xlUp).Row - 1
    Application.ScreenUpdating = True
    MsgBox "OK!用时[" & (Timer - T) & "秒]"
End Sub

YZC51

附件仅供参考
优化计算求助-y.rar (124.02 KB, 下载次数: 4)

2019-6-22 22:50 上传

点击文件名下载附件