[已解决]d.Remove (ar(i, 1)) 出错

605751967

d.Remove (ar(i, 1))   出错。

最佳答案

月排行榜 / 总排行榜

香川群子

2015-10-8 11:52

再换一种算法：
使用1个字典、A列B列各一次循环，最后对字典结果再进行一次循环检查以便输出结果：

1. Sub test2()
   
2.     Dim ar, kr, tr, dic, i&, k1&, k2&, k3&, k4&, m&, r&, t$$$$, tms#
   
3.     tms = Timer
   
4.    
   
5.     [d1].CurrentRegion.Offset(1) = ""
   
6.    
   
7.     m = [a65536].End(3).Row - 1
   
8.     ar = [a2].Resize(m)
   
9.    
   
10.     Set dic = CreateObject("Scripting.Dictionary")
    
11.     For i = 1 To m
    
12.         t = ar(i, 1): If Len(t) Then dic(t) = 1 'A列有标记=1
    
13.     Next
    
14.    
    
15.     m = [b65536].End(3).Row - 1
    
16.     ar = [b2].Resize(m)
    
17.     For i = 1 To m
    
18.         t = ar(i, 1)
    
19.         If Len(t) Then
    
20.             If Not dic.Exists(t) Then 'A0B1
    
21.                 dic(t) = 2 'A没有B有标记为=2
    
22.             Else
    
23.                 If dic(t) = 1 Then dic(t) = 3 '标记=1时则为A有 且B有 改标记=3
    
24.             End If
    
25.         End If
    
26.     Next
    
27.    
    
28.     kr = dic.keys
    
29.     tr = dic.items
    
30.     ReDim br(1 To dic.Count, 1 To 4)
    
31.     For i = 0 To dic.Count - 1
    
32.         r = tr(i): t = kr(i)
    
33.         If r = 1 Then k1 = k1 + 1: br(k1, 1) = t '标记=1时仅A有B没有
    
34.         If r = 2 Then k2 = k2 + 1: br(k2, 2) = t '标记=2时仅B有A没有
    
35.         If r = 3 Then k3 = k3 + 1: br(k3, 3) = t '标记=3时A有B也有
    
36.         k4 = k4 + 1: br(k4, 4) = t '字典中留下的就是A+B合成(A有 or B有)
    
37.     Next
    
38.    
    
39.     MsgBox Format(Timer - tms, "0.00s")
    
40.     [d2].Resize(dic.Count, 4) = br
    
41. End Sub

复制代码

跳转到最佳答案楼层

liuguansky

思路有漏洞吧。。

判断Ｄic存在的时候，如果Ｂ列有重复的且在Ａ列出现即ＤＩＣ中存在，第一次存在判断的时候，Ｄ　ＲＥＭＯＶＥ后，第二次再ＲＥＭＯＶＥ肯定出问题了。

思路的漏洞就是没有规避这种情况：Ｂ列有重复，且在Ａ列出现。你自己再想想思路。

上清宫主

逻辑上就行不通，实践当然通不过
改了下想法：
Dim arr, ar, i&, br(0 To 2)
    t = Timer
    [C2:G65536].ClearContents
    arr = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
    ar = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
    ReDim crr(1 To UBound(arr) + UBound(ar), 0 To 3)
    Set dic = CreateObject("scripting.dictionary")
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(ar)
       If Len(ar(i, 1)) Then
        dic(ar(i, 1)) = ""
        d(ar(i, 1)) = 1
       End If
    Next
    For i = 1 To UBound(arr)
      If Len(arr(i, 1)) Then
        If d(arr(i, 1)) > 0 Then d(arr(i, 1)) = 2
        dic(arr(i, 1)) = ""
      End If
    Next
    For Each tmp In d.keys
       br(d(tmp)) = br(d(tmp)) + 1
       crr(br(d(tmp)), d(tmp)) = tmp
    Next
    i = 0
    For Each tmp In dic.keys
       i = i + 1
       crr(i, 3) = tmp
    Next
    Range("C2").Resize(i, 4) = crr
    MsgBox Format(Timer - t, "0.00秒")

香川群子

使用一个字典，A列B列各一次循环完成分类。
结果再加一次字典结果检查循环，总计3次循环过程，完成输出。

1. Option Base 1
   
2. Sub test()
   
3.     Dim ar, dic, i&, k1&, k2&, k3&, k4&, m&, t$$, tr, tms#
   
4.     tms = Timer
   
5.    
   
6.     [d1].CurrentRegion.Offset(1) = "" '清空输出区域
   
7.    
   
8.     m1 = [a65536].End(3).Row - 1 '获取A列最大行数m1
   
9.     ar = [a2].Resize(m1) '读取A列数据到数组ar
   
10. 
    
11.     m2 = [b65536].End(3).Row - 1 '获取B列最大行数m2
    
12.     ReDim br1(m1, 1), br2(m2, 1), br3(m1, 1), br4(m1 + m2, 1)
    
13.     '建立存放结果的数组br1、br2、br3、br4 (不超过可能个数)
    
14. 
    
15.     Set dic = CreateObject("Scripting.Dictionary") '建立字典dic
    
16.     For i = 1 To m1 '遍历A列数据
    
17.         t = ar(i, 1): If Len(t) Then If Not dic.Exists(t) Then dic(t) = t: k4 = k4 + 1: br4(k4, 1) = t
    
18.         '如不为空则检查是否已经存入字典、并将第1次结果存入br4 即【A+B合成】(A or B)
    
19.     Next
    
20.    
    
21.     ar = [b2].Resize(m2) '读取B列数据到数组ar (数组ar重复使用)
    
22.     For i = 1 To m2 '遍历B列数据
    
23.         t = ar(i, 1)
    
24.         If Len(t) Then '如不为空
    
25.             If dic.Exists(t) Then '如字典存在 则A1B1 即AB都有
    
26.                 If Len(dic(t)) Then dic(t) = "": k3 = k3 + 1: br3(k3, 1) = t
    
27.                 '如字典Item结果不为空则属于第1次出现，标记Item为空 并记入br3【AB都有】
    
28.                 '如Item为空 则为标记已重复 不用统计【重要技巧】
    
29.             Else '如字典不存在 A0B1 即B有A没有
    
30.                 k2 = k2 + 1: br2(k2, 1) = t '记入br2【B有A没有】
    
31.                 k4 = k4 + 1: br4(k4, 1) = t '记入br4【A+B合成】(A or B)
    
32.                 dic(t) = "" '该值Item标记为空 防止重复统计【重要技巧】
    
33.             End If
    
34.         End If
    
35.     Next
    
36.     '以上检查完毕，但A有B没有结果只存在于字典中，还需要检查输出
    
37. 
    
38.     tr = dic.items '提取字典中结果（A有B有时为空、B有时为空、仅A有B没有才是结果）
    
39.     For i = 0 To UBound(tr) '遍历字典结果
    
40.         t = tr(i): If Len(t) Then k1 = k1 + 1: br1(k1, 1) = t
    
41.         '如果Item不为空才是仅A有B没有的正确结果 输出到br1
    
42.     Next
    
43.      
    
44.     '以下为输出   
    
45.     [d2].Resize(k1) = br1
    
46.     [e2].Resize(k2) = br2
    
47.     [f2].Resize(k3) = br3
    
48.     [g2].Resize(k4) = br4
    
49.     MsgBox Format(Timer - tms, "0.00s")
    
50. End Sub

复制代码

香川群子

再换一种算法：
使用1个字典、A列B列各一次循环，最后对字典结果再进行一次循环检查以便输出结果：

1. Sub test2()
   
2.     Dim ar, kr, tr, dic, i&, k1&, k2&, k3&, k4&, m&, r&, t$$$$, tms#
   
3.     tms = Timer
   
4.    
   
5.     [d1].CurrentRegion.Offset(1) = ""
   
6.    
   
7.     m = [a65536].End(3).Row - 1
   
8.     ar = [a2].Resize(m)
   
9.    
   
10.     Set dic = CreateObject("Scripting.Dictionary")
    
11.     For i = 1 To m
    
12.         t = ar(i, 1): If Len(t) Then dic(t) = 1 'A列有标记=1
    
13.     Next
    
14.    
    
15.     m = [b65536].End(3).Row - 1
    
16.     ar = [b2].Resize(m)
    
17.     For i = 1 To m
    
18.         t = ar(i, 1)
    
19.         If Len(t) Then
    
20.             If Not dic.Exists(t) Then 'A0B1
    
21.                 dic(t) = 2 'A没有B有标记为=2
    
22.             Else
    
23.                 If dic(t) = 1 Then dic(t) = 3 '标记=1时则为A有 且B有 改标记=3
    
24.             End If
    
25.         End If
    
26.     Next
    
27.    
    
28.     kr = dic.keys
    
29.     tr = dic.items
    
30.     ReDim br(1 To dic.Count, 1 To 4)
    
31.     For i = 0 To dic.Count - 1
    
32.         r = tr(i): t = kr(i)
    
33.         If r = 1 Then k1 = k1 + 1: br(k1, 1) = t '标记=1时仅A有B没有
    
34.         If r = 2 Then k2 = k2 + 1: br(k2, 2) = t '标记=2时仅B有A没有
    
35.         If r = 3 Then k3 = k3 + 1: br(k3, 3) = t '标记=3时A有B也有
    
36.         k4 = k4 + 1: br(k4, 4) = t '字典中留下的就是A+B合成(A有 or B有)
    
37.     Next
    
38.    
    
39.     MsgBox Format(Timer - tms, "0.00s")
    
40.     [d2].Resize(dic.Count, 4) = br
    
41. End Sub

复制代码