[已解决]请帮助修改删除个位数字相同行的代码

ymq123

请修改代码:
    请用循环或更好的方法，同时删除表2、表3中与表1中各行数字个位数字相同的行，表2未删除的内容存放在表4，表3未删除的内容存放在表5.
    现在的代码不用x循环可以对表2进行操作，加上x循环同时对表2和表3进行操作，出现代码re(cnt, j) = ar2(i1, j)越界(用x循环目的是同时对表2、表3进行操作)。没有查出原因，请老师帮助。

谢谢！

最佳答案

月排行榜 / 总排行榜

雪舞子

2013-12-18 17:04

ymq123 发表于 2013-12-18 15:56
老师你好，在少的情况下调用还行，万一有20个以上的表2、表3，代码就多了。
麻烦你能不能用循环做这道题 ...

1. Sub 求不同()
   
2. Dim dic As Object, rng As Range, arr1, i&, j%, d$, arr, x%
   
3. arr1 = Range("a2").CurrentRegion.Value
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr1)
   
6.         d = ""
   
7.         For j = 1 To UBound(arr1, 2)
   
8.             If arr1(i, j) <> "" Then
   
9.                 d = d & "-" & Right(arr1(i, j), 1)
   
10.             End If
    
11.         Next
    
12.         dic(d) = ""
    
13.         Next
    
14.         
    
15.     For x = 1 To 2
    
16.         arr = Range("h" & 5 * x - 3 & " :m" & 5 * x)
    
17.         Set rng = Range("p" & 5 * x - 3)
    
18.         Call xh2(arr, dic, rng)
    
19.     Next
    
20. End Sub
    
21. 
    
22. 
    
23. Sub xh2(arr, dic, rng)
    
24.     Dim brr()
    
25.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
26.     For i = 1 To UBound(arr)
    
27.         d = ""
    
28.         For j = 1 To UBound(arr, 2)
    
29.             If arr(i, j) <> "" Then
    
30.                 d = d & "-" & Right(arr(i, j), 1)
    
31.             End If
    
32.         Next
    
33.         If Not dic.exists(d) Then
    
34.             n = n + 1
    
35.             For j = 1 To UBound(arr, 2)
    
36.                 brr(n, j) = arr(i, j)
    
37.             Next
    
38.         End If
    
39.     Next
    
40.     rng.Resize(UBound(brr), UBound(brr, 2)) = brr
    
41. End Sub

复制代码

0

跳转到最佳答案楼层

雪舞子

1. Sub 求不同()
   
2. Dim dic As Object, rng As Range, arr1, i&, j%, d$, arr
   
3. arr1 = Range("a2").CurrentRegion.Value
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr1)
   
6.         d = ""
   
7.         For j = 1 To UBound(arr1, 2)
   
8.             If arr1(i, j) <> "" Then
   
9.                 d = d & "-" & Right(arr1(i, j), 1)
   
10.             End If
    
11.         Next
    
12.         dic(d) = ""
    
13.         Next
    
14.         
    
15.     arr = Range("h2:m5")
    
16.     Set rng = Range("p2")
    
17.     Call xh2(arr, dic, rng)
    
18.    
    
19.     arr = Range("h7:m10")
    
20.     Set rng = Range("p7")
    
21.     Call xh2(arr, dic, rng)
    
22.    
    
23. End Sub
    
24. Sub xh2(arr, dic, rng)
    
25.     Dim brr()
    
26.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
27.     For i = 1 To UBound(arr)
    
28.         d = ""
    
29.         For j = 1 To UBound(arr, 2)
    
30.             If arr(i, j) <> "" Then
    
31.                 d = d & "-" & Right(arr(i, j), 1)
    
32.             End If
    
33.         Next
    
34.         If Not dic.exists(d) Then
    
35.             n = n + 1
    
36.             For j = 1 To UBound(arr, 2)
    
37.                 brr(n, j) = arr(i, j)
    
38.             Next
    
39.         End If
    
40.     Next
    
41.     rng.Resize(UBound(brr), UBound(brr, 2)) = brr
    
42. End Sub
    

复制代码

ymq123

雪舞子 发表于 2013-12-18 13:54

老师你好，在少的情况下调用还行，万一有20个以上的表2、表3，代码就多了。
麻烦你能不能用循环做这道题。
谢谢

雪舞子

ymq123 发表于 2013-12-18 15:56
老师你好，在少的情况下调用还行，万一有20个以上的表2、表3，代码就多了。
麻烦你能不能用循环做这道题 ...

1. Sub 求不同()
   
2. Dim dic As Object, rng As Range, arr1, i&, j%, d$, arr, x%
   
3. arr1 = Range("a2").CurrentRegion.Value
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr1)
   
6.         d = ""
   
7.         For j = 1 To UBound(arr1, 2)
   
8.             If arr1(i, j) <> "" Then
   
9.                 d = d & "-" & Right(arr1(i, j), 1)
   
10.             End If
    
11.         Next
    
12.         dic(d) = ""
    
13.         Next
    
14.         
    
15.     For x = 1 To 2
    
16.         arr = Range("h" & 5 * x - 3 & " :m" & 5 * x)
    
17.         Set rng = Range("p" & 5 * x - 3)
    
18.         Call xh2(arr, dic, rng)
    
19.     Next
    
20. End Sub
    
21. 
    
22. 
    
23. Sub xh2(arr, dic, rng)
    
24.     Dim brr()
    
25.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
26.     For i = 1 To UBound(arr)
    
27.         d = ""
    
28.         For j = 1 To UBound(arr, 2)
    
29.             If arr(i, j) <> "" Then
    
30.                 d = d & "-" & Right(arr(i, j), 1)
    
31.             End If
    
32.         Next
    
33.         If Not dic.exists(d) Then
    
34.             n = n + 1
    
35.             For j = 1 To UBound(arr, 2)
    
36.                 brr(n, j) = arr(i, j)
    
37.             Next
    
38.         End If
    
39.     Next
    
40.     rng.Resize(UBound(brr), UBound(brr, 2)) = brr
    
41. End Sub

复制代码

0