[已解决]请老师帮助编写选取数字相同的行

ymq123

提取表1中数字相同的行，把表1中数字不相同的行和多余的数字相同的行删除，生成表2。结果如表3
谢谢！

最佳答案

月排行榜 / 总排行榜

csmctjg

2013-6-8 18:36

ymq123 发表于 2013-6-8 17:39
老师你好：把本题又加二个相同数字的行，怎么不能选出来，请你指教。谢谢！

晕，你的一些空单元格里有空格符，有的没有。
要消空格符用下面代码：

1. Private Sub CommandButton1_Click()
   
2.     Dim i%, j%, k%, str$, arr, arr0(), arr1(), brr(1 To 10000, 1 To 7), d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     k = 0
   
5.     arr = Range("A2").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         For j = 1 To 7
   
8.             str = str & Trim(arr(i, j)) & ","
   
9.         Next
   
10.         d(str) = d(str) + 1
    
11.         str = ""
    
12.     Next
    
13.     arr0 = d.keys
    
14.     arr1 = d.items
    
15.     For i = 0 To UBound(arr0)
    
16.         If arr1(i) > 1 Then
    
17.             k = k + 1
    
18.             For j = 1 To 7
    
19.                 brr(k, j) = Split(arr0(i), ",")(j - 1)
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     [J2].Resize(k, 7) = brr
    
24. End Sub

复制代码

跳转到最佳答案楼层

csmctjg

1. Private Sub CommandButton2_Click()
   
2.     Dim i%, j%, k%, str$, arr, arr0(), arr1(), brr(1 To 10000, 1 To 7), d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("A2").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         For j = 1 To 7
   
7.             str = str & arr(i, j) & ","
   
8.         Next
   
9.         d(str) = d(str) + 1
   
10.         str = ""
    
11.     Next
    
12.     arr0 = d.keys
    
13.     arr1 = d.items
    
14.     For i = 0 To UBound(arr0)
    
15.         If arr1(i) > 1 Then
    
16.             k = k + 1
    
17.             For j = 1 To 7
    
18.                 brr(k, j) = Split(arr0(i), ",")(j - 1)
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     [J2].Resize(k, 7) = brr
    
23. End Sub
    

复制代码

ymq123

csmctjg 发表于 2013-6-8 08:26

老师你好：把本题又加二个相同数字的行，怎么不能选出来，请你指教。谢谢！

csmctjg

ymq123 发表于 2013-6-8 17:39
老师你好：把本题又加二个相同数字的行，怎么不能选出来，请你指教。谢谢！

晕，你的一些空单元格里有空格符，有的没有。
要消空格符用下面代码：

1. Private Sub CommandButton1_Click()
   
2.     Dim i%, j%, k%, str$, arr, arr0(), arr1(), brr(1 To 10000, 1 To 7), d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     k = 0
   
5.     arr = Range("A2").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         For j = 1 To 7
   
8.             str = str & Trim(arr(i, j)) & ","
   
9.         Next
   
10.         d(str) = d(str) + 1
    
11.         str = ""
    
12.     Next
    
13.     arr0 = d.keys
    
14.     arr1 = d.items
    
15.     For i = 0 To UBound(arr0)
    
16.         If arr1(i) > 1 Then
    
17.             k = k + 1
    
18.             For j = 1 To 7
    
19.                 brr(k, j) = Split(arr0(i), ",")(j - 1)
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     [J2].Resize(k, 7) = brr
    
24. End Sub

复制代码