VBA代码运行速度慢-请求优化

axichen

下面这这段代码运行较慢，请求优化，另外B1:B3000要做成动态扩展，B列最后一行有增加数据后自动筛选复制，要怎么写？谢谢！

Option Explicit

Sub 筛选复制()

Dim rng As Range, n%

    Rows("3:3").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

For Each rng In Sheets("HZ").Range("b1:b3000")
    If rng.Value = [a2] Then
         n = n + 1
     Cells(n + 2, "a").Resize(1, 5) = rng.Offset(1, 0).Resize(1, 5).Value
    End If
    Next rng
   
End Sub

duquancai

数组                           

axichen

duquancai 发表于 2018-6-19 21:39
数组

如果用数据公司会更慢。

duquancai

axichen 发表于 2018-6-19 21:43
如果用数据公司会更慢。

数组                  

lsc900707

数据多的话，操作单元格肯定慢。
用数组改写快很多，但没有附件。

liulang0808

目前楼主的代码
可以关闭屏幕刷新，还有前面的select是否有意义？
建议调整，可以进行提速

如果感觉速度还是慢，建议修改成数组

Chip_Kenny

樓主可能對數組與數組公式混淆吧!

Option Explicit

1. Sub 筛选复制()
   
2. Dim rng As Range, n%, ar, i&, j&, k, br
   
3. ar = Sheets("HZ").Range("b1:f3001").Value
   
4. br = [a1].Resize(UBound(ar), 5).Value
   
5. k = [a2].Value
   
6. For i = 1 To UBound(ar) - 1
   
7.     If ar(i, 1) = k Then
   
8.         n = n + 1
   
9.         For j = 1 To 5
   
10.             br(n, j) = ar(i + 1, j)
    
11.         Next
    
12.     End If
    
13. Next
    
14. [a1].Resize(n, 5) = br
    
15. End Sub

复制代码

axichen

liulang0808 发表于 2018-6-20 07:44
目前楼主的代码
可以关闭屏幕刷新，还有前面的select是否有意义？
建议调整，可以进行提速

select 可以取消，原来只是想每次更新后能看到有个结果。谢谢！

axichen

Chip_Kenny 发表于 2018-6-20 09:18
樓主可能對數組與數組公式混淆吧!

Option Explicit

谢谢，回去试下。