[已解决]求简化vba代码

lisa19860622 · 发表于 2012-10-31 15:19

本帖最后由 lisa19860622 于 2012-10-31 16:12 编辑

我以前是学java的,所以,根据以前的基本,语法来修改的这段代码,可运行起来感觉太慢了,所以,请高手帮忙指导下,怎简化代码,(这段代码我写在启动自动执行里,每次启动这文件,都半分多钟才能动4核cpu4g内存.数据在500条以内,数据有重复数据,下面的代码的思路是:先选出包括"lzc"的数据,然后再去掉重复数据.)
现在上附件了.
'更新数据'
Dim arr
'获取数据从德昭表的第一列,第六行开始获取数组
arr = Sheet9.Range("a6:d" & Sheet9.Range("a6").End(xlDown).Row)
'定义费用计算表从第四行开始
j = 4
For i = 1 To UBound(arr)
      '在获取的数据里查找包含"lzc"的数据
      If arr(i, 4) Like "lzc" & "*" Then
         If i < UBound(arr) Then
            bm = arr(i, 4)
            bm2 = arr(i + 1, 4)
         End If
         '判断最后一行数据与倒数第几行数据是不一样'
         If i = UBound(arr) Then

            bm = arr(i - 1, 4)
            bm2 = arr(i, 4)
            Do While bm = bm2
                  k = 2
                  bm = arr(i - k, 4)
                  k = k + 1
            Loop
         End If

         If bm <> bm2 Then
            Sheet10.Cells(j, 1) = arr(i, 1)
            Sheet10.Cells(j, 2) = arr(i, 4)
            j = j + 1
         End If
      End If
Next

最佳答案

月排行榜 / 总排行榜

zjdh

2012-11-1 08:27

本帖最后由 zjdh 于 2012-11-1 08:30 编辑

不去修改你的语句啦，用字典吧：
Sub TEST()
Dim arr
Dim straer As Double, finsh As Double
starer = Timer
Set D = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A3:B" & Sheet1.Range("A3").End(xlDown).Row)
Sheet3.Range("A3:B65536").ClearContents
For I = 1 To UBound(arr)
If arr(I, 2) Like "lzc" & "*" Then D(arr(I, 1)) = arr(I, 2)
Next
Sheet3.Range("A3").Resize(D.Count, 1) = Application.Transpose(D.KEYS)
Sheet3.Range("B3").Resize(D.Count, 1) = Application.Transpose(D.ITEMS)
finsh = Timer
MsgBox "运行时间:" & finsh - starer
End Sub

跳转到最佳答案楼层

zjdh · 发表于 2012-10-31 15:31

最好上传附件便于精简后调试。

初学者2 · 发表于 2012-10-31 15:35

路过学习

上清宫主 · 发表于 2012-10-31 22:09

录个高级筛选的宏吧，很快的
另写代码的话，用字典，同样也很快

zjdh · 发表于 2012-11-1 08:27

本帖最后由 zjdh 于 2012-11-1 08:30 编辑

不去修改你的语句啦，用字典吧：
Sub TEST()
Dim arr
Dim straer As Double, finsh As Double
starer = Timer
Set D = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A3:B" & Sheet1.Range("A3").End(xlDown).Row)
Sheet3.Range("A3:B65536").ClearContents
For I = 1 To UBound(arr)
If arr(I, 2) Like "lzc" & "*" Then D(arr(I, 1)) = arr(I, 2)
Next
Sheet3.Range("A3").Resize(D.Count, 1) = Application.Transpose(D.KEYS)
Sheet3.Range("B3").Resize(D.Count, 1) = Application.Transpose(D.ITEMS)
finsh = Timer
MsgBox "运行时间:" & finsh - starer
End Sub

zjdh · 发表于 2012-11-1 08:36

自己去比较吧

数据自动汇总.rar (18.82 KB, 下载次数: 3)

zjdh · 发表于 2012-11-1 08:57

单用数组也很快
Sub TEST2()
Dim arr
Dim straer As Double, finsh As Double
starer = Timer
Set D = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A3:B" & Sheet1.Range("A3").End(xlDown).Row)
ReDim BRR(1 To 2, 1 To 1)
Sheet3.Range("A3:B65536").ClearContents
For I = 1 To UBound(arr) - 1
      If arr(I, 2) Like "lzc" & "*" Then
         For J = 1 To UBound(BRR)
            If BRR(J, 1) = arr(I, 1) Then Exit For
         Next
         If J > UBound(BRR) Then
            K = K + 1
            ReDim Preserve BRR(1 To 2, 1 To K)
            BRR(1, K) = arr(I, 1)
            BRR(2, K) = arr(I, 2)
         End If
      End If
Next
Sheet3.Range("A3").Resize(K, 2) = Application.Transpose(BRR)
finsh = Timer
MsgBox "运行时间:" & finsh - starer
End Sub

lisa19860622 · 发表于 2012-11-1 11:21

zjdh 发表于 2012-11-1 08:27
不去修改你的语句啦，用字典吧：
Sub TEST()
Dim arr

老师,学生受教了,我那个运行的速度跟这个没法比,下面的回复我就没去看了,一会时间再去看下面的代码.进行比较,看哪个代码更快!!!

kouhogliang · 发表于 2013-7-9 12:44

好好学习天天向上

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