使用字典查询速度很慢，怎么能优化提速

laizhimin0311

代码如下：
Sub 刷新()
On Error Resume Next
Dim A, i, j, K As Long, R As Long
n = Sheet6.Range("h1")
m = Sheet6.Range("i1") + 5
o = m - n + 1

For K = 2 To 6
Set d = CreateObject("scripting.dictionary")
R = Sheet4.[q65536].End(xlUp).Row
A = Sheet4.Range("q4:v" & R)      
For i = 1 To R - 3
    d.Add A(i, 1), A(i, K)
Next i
A = Sheet6.Range("A" & n & ":A" & m)  
For i = 1 To o
    A(i, 1) = d.Item(A(i, 1))
    A(i, 1) = IIf(A(i, 1) = 0, "", A(i, 1))
Next i
Sheet6.Range("A" & n & ":A" & m).Offset(0, K - 1) = A
Set d = Nothing
Next K
End Sub

abc123281

Set d = CreateObject("scripting.dictionary")  这个应该放在循环之外

liulang0808

因为没有附件，只能猜一下了
楼主的表格是否有公式？
Set d = CreateObject("scripting.dictionary")
R = Sheet4.[q65536].End(xlUp).Row
A = Sheet4.Range("q4:v" & R)      
For i = 1 To R - 3
    d.Add A(i, 1), A(i, K)
Next i
A = Sheet6.Range("A" & n & ":A" & m)  
For i = 1 To o
    A(i, 1) = d.Item(A(i, 1))
    A(i, 1) = IIf(A(i, 1) = 0, "", A(i, 1))
Next i
这段代码的取值每次循环有变化吗？如果没有公式，建议放到k这个循环前面使用

有公式，那么根据公式要求具体考虑变通吧

NadrsSaber

Set d = CreateObject("scripting.dictionary")
不管怎么样, 这句都不应该方在循环里...

laizhimin0311

NadrsSaber 发表于 2020-1-19 10:52
Set d = CreateObject("scripting.dictionary")
不管怎么样, 这句都不应该方在循环里...

要放在哪个位置呢？

excel海

放在定义后面去

microyip

不要对单元格进行频繁读写，数组A获取的是单元格，不是单元格里的值

microyip

看了一大轮代码，发现贴主是没事找事干，这个根本就不用什么字典

1. Sub 刷新()
   
2.     Dim vData As Variant, nRow As Long, nCol As Long, nStart As Long, nEnd As Long, vFill As Variant
   
3.    
   
4.     Application.ScreenUpdating = False
   
5.     With Sheet4
   
6.         nRow = .Cells(.Rows.Count, "Q").End(xlUp).Row
   
7.         vData = .Range("Q4:V" & nRow).Value
   
8.     End With
   
9.    
   
10.     With Sheet6
    
11.         nStart = .[H1].Value
    
12.         nEnd = .[I1].Value + 5
    
13.         ReDim vFill(1 To nEnd - nStart + 1, 1 To 6)
    
14.         For nRow = 1 To UBound(vFill)
    
15.             For nCol = 1 To 6
    
16.                 If vData(nRow, nCol) <> 0 Then vFill(nRow, nCol) = vData(nRow, nCol)
    
17.             Next nCol
    
18.         Next nRow
    
19.         .Range("A" & nStart & ":A" & nEnd).Resize(, 6) = vFill
    
20.      End With
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码