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

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 = 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 08:35

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

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

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

感谢老师给力！！！
大青枣有烤蹄

为了方便记录学习过程，这个题我发新帖了，做好后上网址并短消息，再请老师批卷

office2008 · 发表于 2010-12-8 08:44

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

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 · 发表于 2010-12-8 08:45

原帖由 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 · 发表于 2010-12-8 08:52

原帖由 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 · 发表于 2010-12-8 09:00

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

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

状态栏求和= 196560.8995

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

再把鼠标选中 K列 ...

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

cnzjjhzjf · 发表于 2010-12-8 09:05

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

camle · 发表于 2010-12-8 09:09

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

加油~~~

excelflower · 发表于 2010-12-8 09:15

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

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

excelflower · 发表于 2010-12-8 09:17

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

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

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

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

		自动登录	找回密码
密码			免费注册

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