[已解决]删除表格里多余的数字相同的行

ymq123

请老师编写代码：删除表格里多余的数字相同的行。谢谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-1 15:40

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, arrtemp
   
3.     Dim rg As Range
   
4.     Dim result()
   
5. 
   
6.     On Error Resume Next
   
7. 
   
8.     Set rg = Range("a2:g23").SpecialCells(xlCellTypeBlanks)
   
9.     If Not rg Is Nothing Then rg = " "
   
10.     arr = Range("a2:g23")
    
11.     Set rg = Nothing
    
12.     Dim dic As Object, str$
    
13.     Set dic = CreateObject("scripting.dictionary")
    
14. 
    
15.     For i = LBound(arr) To UBound(arr)
    
16.         str = Join(WorksheetFunction.Index(arr, i, 0), "#")
    
17.         dic(str) = dic(str) + 1
    
18.     Next
    
19.     i = 0
    
20.     ReDim result(1 To dic.Count)
    
21.     For Each arrtemp In dic.keys
    
22.     i = i + 1
    
23.     result(i) = Split(arrtemp, "#")
    
24.     Next
    
25.     If dic.Count > 0 Then
    
26.         Range("j1").CurrentRegion.ClearContents
    
27.         Range("j1") = "表2"
    
28.         result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(result))
    
29.         [j2].Resize(UBound(result), UBound(result, 2)) = result
    
30.     End If
    
31. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

怎么又是这样的题，周末不是发了一贴的嘛。

hwc2ycy

[已解决]请老师编写代码
http://www.excelpx.com/thread-298229-1-1.html

你老把这类似的问题这么发题，就有灌水的嫌疑了。

ymq123

hwc2ycy 发表于 2013-4-1 14:43
[已解决]请老师编写代码
http://www.excelpx.com/thread-298229-1-1.html

你好：你上次发的不是我想的，你把相同数字的行全部删除了，应该删除多余的。谢谢

hwc2ycy

那就是个参数的问题。

人家给你解决的问题，你也要自己学习下，不说举一反三，起码你要能读懂。

不然次次只会要鱼而不会渔。

ymq123

hwc2ycy 发表于 2013-4-1 15:25
那就是个参数的问题。

人家给你解决的问题，你也要自己学习下，不说举一反三，起码你要能读懂。

你好：你说对，我是在学，因为我正在过这个入门坎，解决数组和字典的用法。

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, arrtemp
   
3.     Dim rg As Range
   
4.     Dim result()
   
5. 
   
6.     On Error Resume Next
   
7. 
   
8.     Set rg = Range("a2:g23").SpecialCells(xlCellTypeBlanks)
   
9.     If Not rg Is Nothing Then rg = " "
   
10.     arr = Range("a2:g23")
    
11.     Set rg = Nothing
    
12.     Dim dic As Object, str$
    
13.     Set dic = CreateObject("scripting.dictionary")
    
14. 
    
15.     For i = LBound(arr) To UBound(arr)
    
16.         str = Join(WorksheetFunction.Index(arr, i, 0), "#")
    
17.         dic(str) = dic(str) + 1
    
18.     Next
    
19.     i = 0
    
20.     ReDim result(1 To dic.Count)
    
21.     For Each arrtemp In dic.keys
    
22.     i = i + 1
    
23.     result(i) = Split(arrtemp, "#")
    
24.     Next
    
25.     If dic.Count > 0 Then
    
26.         Range("j1").CurrentRegion.ClearContents
    
27.         Range("j1") = "表2"
    
28.         result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(result))
    
29.         [j2].Resize(UBound(result), UBound(result, 2)) = result
    
30.     End If
    
31. End Sub

复制代码

hwc2ycy

字典是对象里最容易掌握的了。
属性加方法一共才10个。

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, arrtemp
   
3.     Dim rg As Range
   
4.     Dim result()
   
5.     Dim i As Integer
   
6.     On Error Resume Next
   
7.     Application.ScreenUpdating = False
   
8. 
   
9.     Set rg = Range("a2:g23").SpecialCells(xlCellTypeBlanks)
   
10.     If Not rg Is Nothing Then rg = " "
    
11.     Set rg = Nothing
    
12. 
    
13.     arr = Range("a2:g23")
    
14. 
    
15.     Dim dic As Object, str$
    
16.     Set dic = CreateObject("scripting.dictionary")
    
17. 
    
18.     For i = LBound(arr) To UBound(arr)
    
19.         str = Join(WorksheetFunction.Index(arr, i, 0), "#")
    
20.         dic(str) = dic(str) + 1
    
21.     Next
    
22. 
    
23.     i = 0
    
24.     ReDim result(1 To dic.Count)
    
25.     For Each arrtemp In dic.keys
    
26.         i = i + 1
    
27.         result(i) = Split(arrtemp, "#")
    
28.     Next
    
29.    
    
30.    
    
31.     If dic.Count > 0 Then
    
32.         [j1].CurrentRegion.ClearContents
    
33.         [j1] = "表2"
    
34.         result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(result))
    
35.         [j2].Resize(UBound(result), UBound(result, 2)) = result
    
36.     End If
    
37.    
    
38.     Set dic = Nothing
    
39.     Application.ScreenUpdating = True
    
40.    
    
41. End Sub

复制代码