for循环运行速度优化,防止未响应提示

zhoulingzhoulin

本人写了个for循环,行数少能顺利执行,3万行就出现未响应的提示,听说数组能优化,麻烦哪位老师指导,感谢!!!
Sub 导入外部文件()
Dim X As Integer
Dim Y As Integer
sh3 = ThisWorkbook.Sheets("UUtranRelation").Cells(1048576, 3).End(xlUp).Row

de1 = ThisWorkbook.Sheets("删除小区信息").Cells(1048576, 1).End(xlUp).Row

Sheets("UUtranRelation").Activate
For X = sh3 To 6 Step -1
For Y = de1 To 2 Step -1
    If (Sheets("UUtranRelation").Cells(X, 5) = Sheets("删除小区信息").Cells(Y, 1) And Sheets("UUtranRelation").Cells(X, 6) = Sheets("删除小区信息").Cells(Y, 2)) Then
    Sheets("UUtranRelation").Cells(X, 2) = "D"
Exit For
    Else
    Sheets("UUtranRelation").Cells(X, 2) = "P"
    End If
    Next Y
    Next X

End Sub

一把小刀闯天下

'自己测试一下

Option Explicit

Sub test()
  Dim i As Long, dic, arr, t As String
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("删除小区信息").[a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    dic(CStr(arr(i, 1)) & CStr(arr(i, 2))) = vbNullString
  Next
  With Sheets("UUtranRelation")
    arr = .[a1].CurrentRegion
    For i = 6 To UBound(arr, 1)
      t = CStr(arr(i, 5)) & CStr(arr(i, 6))
      arr(i - 5, 1) = IIf(dic.exists(t), "D", "P")
    Next
    .[b6].Resize(UBound(arr, 1) - 5) = arr
  End With
End Sub

liulang0808

1. 
   
2. Sub 导入外部文件arr()
   
3.     Dim X As Integer
   
4.     Dim Y As Integer
   
5.     brr = ThisWorkbook.Sheets("UUtranRelation").UsedRange
   
6.     sh3 = ThisWorkbook.Sheets("UUtranRelation").Cells(1048576, 3).End(xlUp).Row
   
7.     arr = ThisWorkbook.Sheets("删除小区信息").UsedRange
   
8.     de1 = ThisWorkbook.Sheets("删除小区信息").Cells(1048576, 1).End(xlUp).Row
   
9.     Application.ScreenUpdating = False
   
10.     Sheets("UUtranRelation").Activate
    
11.     For X = sh3 To 6 Step -1
    
12.         For Y = de1 To 2 Step -1
    
13.             If (brr(X, 5) = arr(Y, 1) And brr(X, 6) = arr(Y, 2)) Then
    
14.                 brr(X, 2) = "D"
    
15.                 Exit For
    
16.             Else
    
17.                 brrs(X, 2) = "P"
    
18.             End If
    
19.         Next Y
    
20.     Next X
    
21.     ThisWorkbook.Sheets("UUtranRelation").UsedRange = brr
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

楼主自己测试看看吧

zhoulingzhoulin

一把小刀闯天下 发表于 2018-7-8 11:53
'自己测试一下

Option Explicit

成功搞定,但代码我看不懂,高手