[已解决]解决了老问题，怎么原代码失灵了？

KDZ

      
             寡妇添儿子，在众人的帮忙下，好不容易的得到代码，在解决溢、下标越界等出问题后，怎么代码达不到原来的目了？请各位大 帮一把手，把这个孩子顺利生下来！谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2014-3-14 09:57

我也搞不懂为什么，只能把一个数组拆分为3个小数组，不然就溢出。另外注意到你QRS列里面有非数字类型，代码中也一并考虑了。

1. Sub 删除重复行()
   
2.     Dim d, DelRng As Range, i&, p$, j%
   
3.     Dim arr
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With ActiveSheet
   
6.         Set DelRng = .Rows(65536)
   
7.         row1 = .Range("E" & .Rows.Count).End(xlUp).Row
   
8.         arr = .Range("A5:I" & row1)    '前几列
   
9.         brr = .Range("q5:s" & row1)    '17 18 19列
   
10.         crr = .Range("v5:ac" & row1)    '22--29列
    
11.         For i = 1 To UBound(arr)
    
12.             If Len(crr(i, 1)) = 0 And Len(crr(i, 8)) = 0 Then   '在22列、29列都为空的行中筛选
    
13.                 p = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
    
14.                 d(p) = d(p) & "," & i   '把1、2、5、9四列相同的行放入字典
    
15.             End If
    
16.         Next
    
17.         dk = d.items
    
18.         For k = 0 To UBound(dk)
    
19.             xrr = Split(dk(k), ",")
    
20.             s1 = 0: s2 = 0   's1判断19列是否有数，s2判断18列是否有数
    
21.             k1 = 0: k2 = 0: k3 = 0
    
22.             For m = 1 To UBound(xrr)
    
23.                 i = Val(xrr(m))
    
24.                 s1 = s1 + IIf(IsNumeric(brr(i, 3)), brr(i, 3), 1) '考虑到QRS列有非数字情形
    
25.                 s2 = s2 + IIf(IsNumeric(brr(i, 2)), brr(i, 2), 1)
    
26.             Next
    
27.             For m = 1 To UBound(xrr)
    
28.                 i = Val(xrr(m))
    
29.                 If s1 > 0 Then
    
30.                     If brr(i, 3) = 0 Then
    
31.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
32.                     Else
    
33.                         k1 = k1 + 1
    
34.                         If k1 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
35.                     End If
    
36.                 ElseIf s2 > 0 Then
    
37.                     If brr(i, 2) = 0 Then
    
38.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
39.                     Else
    
40.                         k2 = k2 + 1
    
41.                         If k2 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
42.                     End If
    
43.                 Else
    
44.                     If brr(i, 1) = 0 Then
    
45.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
46.                     Else
    
47.                         k3 = k3 + 1
    
48.                         If k3 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
49.                     End If
    
50.                 End If
    
51.             Next
    
52.         Next
    
53.         DelRng.Delete
    
54.     End With
    
55. End Sub

复制代码

跳转到最佳答案楼层

KDZ

请各位大侠，老师们指教.

grf1973

重新改了下代码。虽然有点啰嗦，但条理比较清晰。

1. Sub 删除重复行()
   
2.     Dim d, DelRng As Range, i&, p$, j%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With ActiveSheet
   
5.         Set DelRng = .Rows(65536)
   
6.         row1 = .Range("E" & .Rows.Count).End(xlUp).Row
   
7.         arr = .Range("A5:ac" & row1)
   
8. 
   
9.         For i = 1 To UBound(arr)
   
10.             If Len(arr(i, 22)) = 0 And Len(arr(i, 29)) = 0 Then   '在22列、29列都为空的行中筛选
    
11.                 p = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
    
12.                 d(p) = d(p) & "," & i   '把1、2、5、9四列相同的行放入字典
    
13.             End If
    
14.         Next
    
15.         dk = d.items
    
16.         For k = 0 To UBound(dk)
    
17.             xrr = Split(dk(k), ",")
    
18.             s1 = 0: s2 = 0   's1判断19列是否有数，s2判断18列是否有数
    
19.             For m = 1 To UBound(xrr)
    
20.                 i = Val(xrr(m))
    
21.                 s1 = s1 + arr(i, 19): s2 = s2 + arr(i, 18)
    
22.             Next
    
23.             If s1 > 0 Then
    
24.                 For m = 1 To UBound(xrr)
    
25.                     i = Val(xrr(m))
    
26.                     If arr(i, 19) = 0 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
27.                 Next
    
28.             ElseIf s2 > 0 Then
    
29.                 For m = 1 To UBound(xrr)
    
30.                     i = Val(xrr(m))
    
31.                     If arr(i, 18) = 0 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
32.                 Next
    
33.             Else
    
34.                 For m = 1 To UBound(xrr)
    
35.                     i = Val(xrr(m))
    
36.                     If arr(i, 17) = 0 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
37.                 Next
    
38.             End If
    
39.         Next
    
40.         DelRng.Delete
    
41.     End With
    
42. End Sub

复制代码

grf1973

代码可以简化一点：

1. Sub 删除重复行()
   
2.     Dim d, DelRng As Range, i&, p$, j%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With ActiveSheet
   
5.         Set DelRng = .Rows(65536)
   
6.         row1 = .Range("E" & .Rows.Count).End(xlUp).Row
   
7.         arr = .Range("A5:ac" & row1)
   
8. 
   
9.         For i = 1 To UBound(arr)
   
10.             If Len(arr(i, 22)) = 0 And Len(arr(i, 29)) = 0 Then   '在22列、29列都为空的行中筛选
    
11.                 p = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
    
12.                 d(p) = d(p) & "," & i   '把1、2、5、9四列相同的行放入字典
    
13.             End If
    
14.         Next
    
15.         dk = d.items
    
16.         For k = 0 To UBound(dk)
    
17.             xrr = Split(dk(k), ",")
    
18.             s1 = 0: s2 = 0   's1判断19列是否有数，s2判断18列是否有数
    
19.             For m = 1 To UBound(xrr)
    
20.                 i = Val(xrr(m))
    
21.                 s1 = s1 + arr(i, 19): s2 = s2 + arr(i, 18)
    
22.             Next
    
23.             For m = 1 To UBound(xrr)
    
24.                 i = Val(xrr(m))
    
25.                 If s1 > 0 Then
    
26.                     If arr(i, 19) = 0 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
27.                 ElseIf s2 > 0 Then
    
28.                     If arr(i, 18) = 0 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
29.                 Else
    
30.                     If arr(i, 17) = 0 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
31.                 End If
    
32.             Next
    
33.         Next
    
34.         DelRng.Delete
    
35.     End With
    
36. End Sub
    

复制代码

grf1973

为什么文件这么大？请看附件。

KDZ

grf1973 发表于 2014-3-13 10:56
为什么文件这么大？请看附件。

只是最高孩次行如果是 2 行以上，只要保留基中唯一一行，其它的最高孩次行也全部删除，解决了就完全解决问题了，还请赐教！ 谢谢！！

grf1973

是22、29列都为空的前提下只保留1行最高孩次吗？比如你附件中的第5行保留的话，第8行是否还要保留？

grf1973

1. Sub 删除重复行()
   
2.     Dim d, DelRng As Range, i&, p$, j%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With ActiveSheet
   
5.         Set DelRng = .Rows(65536)
   
6.         row1 = .Range("E" & .Rows.Count).End(xlUp).Row
   
7.         arr = .Range("A5:ac" & row1)
   
8. 
   
9.         For i = 1 To UBound(arr)
   
10.             If Len(arr(i, 22)) = 0 And Len(arr(i, 29)) = 0 Then   '在22列、29列都为空的行中筛选
    
11.                 p = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
    
12.                 d(p) = d(p) & "," & i   '把1、2、5、9四列相同的行放入字典
    
13.             End If
    
14.         Next
    
15.         dk = d.items
    
16.         For k = 0 To UBound(dk)
    
17.             xrr = Split(dk(k), ",")
    
18.             s1 = 0: s2 = 0   's1判断19列是否有数，s2判断18列是否有数
    
19.             k1 = 0: k2 = 0: k3 = 0
    
20.             For m = 1 To UBound(xrr)
    
21.                 i = Val(xrr(m))
    
22.                 s1 = s1 + arr(i, 19): s2 = s2 + arr(i, 18)
    
23.             Next
    
24.             For m = 1 To UBound(xrr)
    
25.                 i = Val(xrr(m))
    
26.                 If s1 > 0 Then
    
27.                     If arr(i, 19) = 0 Then
    
28.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
29.                     Else
    
30.                         k1 = k1 + 1
    
31.                         If k1 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
32.                     End If
    
33.                 ElseIf s2 > 0 Then
    
34.                     If arr(i, 18) = 0 Then
    
35.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
36.                     Else
    
37.                         k2 = k2 + 1
    
38.                         If k2 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
39.                     End If
    
40.                 Else
    
41.                     If arr(i, 17) = 0 Then
    
42.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
43.                     Else
    
44.                         k3 = k3 + 1
    
45.                         If k3 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
46.                     End If
    
47.                 End If
    
48.             Next
    
49.         Next
    
50.         DelRng.Delete
    
51.     End With
    
52. End Sub

复制代码

这段代码只是在22、29列都为空的前提下保留1行最高孩次。

KDZ

grf1973 发表于 2014-3-13 13:48
这段代码只是在22、29列都为空的前提下保留1行最高孩次。

你好，谢谢！答案是对的，不过用到我的表格内，又还原到“溢出”了，怎么办？请指导，谢谢！！

grf1973

我也搞不懂为什么，只能把一个数组拆分为3个小数组，不然就溢出。另外注意到你QRS列里面有非数字类型，代码中也一并考虑了。

1. Sub 删除重复行()
   
2.     Dim d, DelRng As Range, i&, p$, j%
   
3.     Dim arr
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With ActiveSheet
   
6.         Set DelRng = .Rows(65536)
   
7.         row1 = .Range("E" & .Rows.Count).End(xlUp).Row
   
8.         arr = .Range("A5:I" & row1)    '前几列
   
9.         brr = .Range("q5:s" & row1)    '17 18 19列
   
10.         crr = .Range("v5:ac" & row1)    '22--29列
    
11.         For i = 1 To UBound(arr)
    
12.             If Len(crr(i, 1)) = 0 And Len(crr(i, 8)) = 0 Then   '在22列、29列都为空的行中筛选
    
13.                 p = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
    
14.                 d(p) = d(p) & "," & i   '把1、2、5、9四列相同的行放入字典
    
15.             End If
    
16.         Next
    
17.         dk = d.items
    
18.         For k = 0 To UBound(dk)
    
19.             xrr = Split(dk(k), ",")
    
20.             s1 = 0: s2 = 0   's1判断19列是否有数，s2判断18列是否有数
    
21.             k1 = 0: k2 = 0: k3 = 0
    
22.             For m = 1 To UBound(xrr)
    
23.                 i = Val(xrr(m))
    
24.                 s1 = s1 + IIf(IsNumeric(brr(i, 3)), brr(i, 3), 1) '考虑到QRS列有非数字情形
    
25.                 s2 = s2 + IIf(IsNumeric(brr(i, 2)), brr(i, 2), 1)
    
26.             Next
    
27.             For m = 1 To UBound(xrr)
    
28.                 i = Val(xrr(m))
    
29.                 If s1 > 0 Then
    
30.                     If brr(i, 3) = 0 Then
    
31.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
32.                     Else
    
33.                         k1 = k1 + 1
    
34.                         If k1 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
35.                     End If
    
36.                 ElseIf s2 > 0 Then
    
37.                     If brr(i, 2) = 0 Then
    
38.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
39.                     Else
    
40.                         k2 = k2 + 1
    
41.                         If k2 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
42.                     End If
    
43.                 Else
    
44.                     If brr(i, 1) = 0 Then
    
45.                         Set DelRng = Union(DelRng, .Rows(i + 4))
    
46.                     Else
    
47.                         k3 = k3 + 1
    
48.                         If k3 > 1 Then Set DelRng = Union(DelRng, .Rows(i + 4))
    
49.                     End If
    
50.                 End If
    
51.             Next
    
52.         Next
    
53.         DelRng.Delete
    
54.     End With
    
55. End Sub

复制代码