不少版主看后都认为超难：全表代码寻优化提速，已写功能需求及原始数据清单

office2008

下面是 excelflower 的一段程序， 她没有考虑最后一组数组，所以最后 的 分类小计 ，人个合计 是没有的

Sub MySumT()
    Dim i&, Arr, X#, Y#, j%
    Arr = Range("a3:k" & [a65536].End(3).Row)
    For i = 2 To UBound(Arr)
        X = X + Arr(i - 1, 8)
        Y = Y + Arr(i - 1, 8)
        If Arr(i - 1, 1) <> Arr(i, 1) Then
            Arr(i - 1, 11) = Y
            Y = 0
        End If
        If Arr(i, 1) & Arr(i, 9) <> Arr(i - 1, 1) & Arr(i - 1, 9) Then
            Arr(i - 1, 10) = X
            X = 0
        End If
    Next i
    [a3].Resize(UBound(Arr), 11) = Arr
    Range("A3:K6" & UBound(Arr) + 2).Borders.LineStyle = 1
End Sub

而这下面一段 就考虑到了最后一组数组

Arr = .Range("m3:w" & .[m65536].End(3).Row + 1)
        For i = 2 To UBound(Arr)
            X = X + Arr(i - 1, 8)
            Y = Y + Arr(i - 1, 8)
            If Arr(i - 1, 1) <> Arr(i, 1) Then
                Arr(i - 1, 11) = Y
                Y = 0
            End If
            If Arr(i, 1) & Arr(i, 9) <> Arr(i - 1, 1) & Arr(i - 1, 9) Then
                Arr(i - 1, 10) = X
                X = 0
            End If
        Next i
        .[m3].Resize(UBound(Arr) - 1, 11) = Arr
        .Range("m3:w" & UBound(Arr) + 1).Borders.LineStyle = 1

另外 如果一个表（原始生产数据清单）数据在2万行以上，就尽量使用 数组和字典，在同一工作簿内取数据不要轻易使用ADO+SQL，使用次数多会越来越慢，整个一个统计程序（就是把 原始生产数据清单 表 数据 按要求提取到 查询表 中的一段程序） 现在我用数组+字典速度是 ADO+SQL 的 6倍以上， 原来需要 6秒 左右，现在只需1 秒不到 并且包含 分类小计 ，人个合计， 不管怎样 excelflower  程序 也是比较 好的，慎用 ADO+SQL 。

就象 今天 灰狍法师 所说， 程序中我昨天 用 ReDim preserve  crr( 1 To 11，1 to k )来决定动态数组 大小，后来感觉吃内存厉害，不如直接一下子扩展静态数组， redim  crr(1 To UBound(Arr), 1 To 11) ,虽然数组中实际需要的远远小于需要的，但可以通过在程序中满足要求的次数 K 来限定我要截取 的数组大小，比如.Range("a3").Resize(k, 11) = crr  ,  所以说多考虑几下，是能够 优化程序 和 改进速度的。

[ 本帖最后由 office2008 于 2010-12-8 08:41 编辑 ]

excelflower

原帖由 灰袍法师 于 2010-12-8 01:28 发表


可以，不过如果RANGE是不相邻的区域，或者相邻但是合并后的形状不是矩形，那么只有第一个区域会赋值给数组

另外，如果是相邻的区域而且形成一个矩形区域，那么所有区域都会赋值给数组
请在A1:C3区域填入某些 ...

感谢老师给力！！！
大青枣有烤蹄
为了方便记录学习过程，这个题我发新帖了，做好后上网址并短消息，再请老师批卷

office2008

这段程序就是 查询表中的，还可以修改

Sub main()
    t = Timer
    Application.ScreenUpdating = False
    Dim i&, j&, Arr, Brr, s As String, crr()
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("齿数与生产单价")
        Brr = .Range("a2:b" & .[a65536].End(3).Row)
        For i = 1 To UBound(Brr)
            dic(Brr(i, 1)) = Brr(i, 2)
        Next i
    End With
    With Sheets("原始生产数据清单")
        Arr = .Range("a2:o" & .[a65536].End(3).Row)
        ReDim crr(1 To UBound(Arr), 1 To 11)  ' 原来想用动态,后来觉得不妥
        For i = 1 To UBound(Arr)
            'Arr(i, 15) = Left(Arr(i, 5), 1)
            s = Arr(i, 3) & "/" & Arr(i, 4) & "/" & Arr(i, 8)
            If Not dic.exists(s) Then
                k = k + 1
                dic(s) = k
                crr(k, 1) = Arr(i, 3)
                crr(k, 2) = Arr(i, 4)
                crr(k, 3) = Arr(i, 8)
                If dic.exists(Arr(i, 8)) Then
                    crr(k, 7) = dic(Arr(i, 8))
                Else
                    crr(k, 7) = Arr(i, 9)         '有可能在字典中没有，以防万一
         End If
                crr(k, 9) = Left(Arr(i, 5), 1)
            End If
            crr(dic(s), 4) = crr(dic(s), 4) + Arr(i, 11)
            crr(dic(s), 5) = crr(dic(s), 5) + Arr(i, 12)
            crr(dic(s), 6) = crr(dic(s), 6) + Arr(i, 13)
            crr(dic(s), 8) = crr(dic(s), 8) + Arr(i, 14)
         Next i
    End With
    With Sheets("查询表")
        .Range("m3:am20000").ClearContents
        .Range("m3").Resize(k, 11) = crr
        .Range("m3").Resize(k, 11).Sort Key1:=Range("M3"), Order1:=xlAscending, Key2:=Range("u3") _
                                      , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1
        Arr = .Range("m3:w" & .[m65536].End(3).Row + 1)
        For i = 2 To UBound(Arr)
            X = X + Arr(i - 1, 8)
            Y = Y + Arr(i - 1, 8)
            If Arr(i - 1, 1) <> Arr(i, 1) Then
                Arr(i - 1, 11) = Y
                Y = 0
            End If
            If Arr(i, 1) & Arr(i, 9) <> Arr(i - 1, 1) & Arr(i - 1, 9) Then
                Arr(i - 1, 10) = X
                X = 0
            End If
        Next i
        .[m3].Resize(UBound(Arr) - 1, 11) = Arr
        .Range("m3:w" & UBound(Arr) + 1).Borders.LineStyle = 1
        Application.ScreenUpdating = True
        .Range("q1") = Timer - t
    End With
End Sub

excelflower

原帖由 office2008 于 2010-12-8 08:26 发表
下面是 excelflower 的一段程序， 她没有考虑最后一组数组，所以最后 的 分类小计 ，人个合计 是没有的

Sub MySumT()
    Dim i&, Arr, X#, Y#, j%
    Arr = Range("a3:k" & [a65536].End(3).Row)
    For i  ...

多谢老师赐教！！！
我的代码最后一行有问题：Range("A3:K6" & UBound(Arr) + 2).Borders.LineStyle = 1，应该删除这个“6”。
我的代码有小计和合计的，放在右边了。

office2008

原帖由 excelflower 于 2010-12-8 08:45 发表

多谢老师赐教！！！
我的代码最后一行有问题：Range("A3:K6" & UBound(Arr) + 2).Borders.LineStyle = 1，应该删除这个“6”。
我的代码有小计和合计的，放在右边了。

你误会了,你程序很好,没错, 错心了,你把 6 去掉,再运行一次, 然后 用鼠标 选中 查询表 的 H 列

状态栏 求和= 196560.8995

再把鼠标  选中 J 列  后 状态栏 求和= 196550.8255

再把鼠标  选中 K列  后 状态栏 求和= 194043.3425

其实这 三者应该 相等, 你也就能明白我说什么了.

[ 本帖最后由 office2008 于 2010-12-8 08:53 编辑 ]

excelflower

原帖由 office2008 于 2010-12-8 08:52 发表



你误会了,你程序很好,没错, 错心了,你把 6 去掉,再运行一次, 然后 用鼠标 选中 查询表 的 H 列

状态栏 求和= 196560.8995

再把鼠标  选中 J 列  后 状态栏 求和= 196550.8255

再把鼠标  选中 K列  ...

老师你好！
我的代码是没考虑最后一组数据！！！多谢老师赐教！！！！

cnzjjhzjf

没什么难的呀，楼主吹吧，这类问题还有版主解决？晕死！可以用SQL语名编写代码，很简单的嘛！

camle

Office2008大大也来了...
此贴貌似已经跑题,变成花花教学贴了.
加油~~~

excelflower

原帖由 camle 于 2010-12-8 09:09 发表
Office2008大大也来了...
此贴貌似已经跑题,变成花花教学贴了.
加油~~~

老师早上好！是的，这个帖学了很多知识

excelflower

原帖由 灰袍法师 于 2010-12-8 01:28 发表


可以，不过如果RANGE是不相邻的区域，或者相邻但是合并后的形状不是矩形，那么只有第一个区域会赋值给数组

另外，如果是相邻的区域而且形成一个矩形区域，那么所有区域都会赋值给数组
请在A1:C3区域填入某些 ...

老师你好！交作业了http://club.excelhome.net/viewth ... e%3D1&frombbs=1