求优化宏，运行超30W行就未响应

nbmitxihc

如图：AB为源数据，因附件不能超2M,所以行数少了很多，行数超1W就得2分钟时间，
C-E为生成项，见代码，求大神给优化下 工作簿1.rar (64.73 KB, 下载次数: 11)

2018-10-12 19:52 上传

点击文件名下载附件

Sub 核查()
    Set d = CreateObject("scripting.dictionary")
    Set Z = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Arr = [a1].CurrentRegion
    Columns("c:e") = ""
    ii = 1
    Cells(1, 3) = "两者关系"
    Cells(1, 4) = "双向去重"
    Cells(1, 5) = "双向去重"
    For j = 2 To UBound(Arr)
        If Z.exists(Arr(j, 1) & "#" & Arr(j, 2)) Then

        Else
           Z(Arr(j, 1) & "#" & Arr(j, 2)) = j

        End If

        If d.exists(Arr(j, 1) & "#" & Arr(j, 2)) Or d.exists(Arr(j, 2) & "#" & Arr(j, 1)) Then

        Else
            ii = ii + 1
            d(Arr(j, 1) & "#" & Arr(j, 2)) = j
            Cells(ii, 4) = Arr(j, 1)
            Cells(ii, 5) = Arr(j, 2)

        End If
    Next j

    For x = 2 To UBound(Arr)

    If Z.exists(Arr(x, 1) & "#" & Arr(x, 2)) And Z.exists(Arr(x, 2) & "#" & Arr(x, 1)) Then

             Cells(x, 3) = "双方向添加"
        Else

             Cells(x, 3) = "单方向添加"
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

jiangxiaoyun

d、e列不是多余的？

Simon_Zhu

单看你贴出的这部分代码:

Cells(ii, 4) = Arr(j, 1)
Cells(ii, 5) = Arr(j, 2)
...
Cells(x, 3) = "双方向添加"
Else
Cells(x, 3) = "单方向添加"
...


使用Cells进行数据写入，数据量大的时候肯定慢啊。

简单优化的建议：
重新定义一个数组brr，将Cells(ii, 4) 这一类的数据先写进数组，然后一次写入工作表，
速度会提高很多，供参考！

lsc900707

1. Sub 核查1()
   
2.     tms = Timer
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set Z = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Columns("c:e") = ""
   
7.     [c1:e1] = Array("两者关系", "双向去重", "双向去重")
   
8.     arr = [a1].CurrentRegion
   
9.     m = 1
   
10.     For j = 2 To UBound(arr)
    
11.         If Z.exists(arr(j, 1) & arr(j, 2)) Then
    
12.         Else
    
13.            Z(arr(j, 1) & arr(j, 2)) = j
    
14.         End If
    
15.         If d.exists(arr(j, 1) & arr(j, 2)) Or d.exists(arr(j, 2) & arr(j, 1)) Then
    
16.         Else
    
17.             m = m + 1
    
18.             d(arr(j, 1) & arr(j, 2)) = j
    
19.             arr(m, 4) = arr(j, 1)
    
20.             arr(m, 5) = arr(j, 2)
    
21.         End If
    
22.     Next
    
23.     For x = 2 To UBound(arr)
    
24.         If Z.exists(arr(x, 1) & arr(x, 2)) And Z.exists(arr(x, 2) & arr(x, 1)) Then
    
25.              arr(x, 3) = "双方向添加"
    
26.         Else
    
27.             arr(x, 3) = "单方向添加"
    
28.         End If
    
29.     Next
    
30.     [a1].CurrentRegion = arr
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox Format(Timer - tms, "0.0000s")
    
33. End Sub

复制代码

lsc900707

测试对比一下：

nbmitxihc

lsc900707 发表于 2018-10-13 07:52

谢谢大神指导，30W行运行 56秒左右生成，非常感谢

nbmitxihc

lsc900707 发表于 2018-10-13 07:52

单个写入cells()变成arr存入数组，厉害了

lsc900707

nbmitxihc 发表于 2018-10-14 20:44
单个写入cells()变成arr存入数组，厉害了

好用就送个花呗！呵呵。