[已解决]Sub 删除选定列有重复数据的行()

yjwdjfqb

Sub 删除选定列有重复数据的行()
    Dim x As Range
    On Error Resume Next
    Set x = Application.InputBox(prompt:="请选择要操作的列或者列区域", Title:="提示", Default:="请选择", Type:=8)
    If x Is Nothing Then Exit Sub
    Range("x").SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub


我是想，利用这个选择框，选择我的操作列，或者是操作列的指定区域（如：　弹出选择框时，我选择了，$C$5：$C$15，这个列区域时，就是要删除$C$5：$C$15之间有重复数据的行；当选择$C:$C时，就是删除C列中，有重复数据的行。）

删除重复数据时，保留最后一次出现的数据。

请大家帮我修改下。
谢谢朋友们了！

删除选定列有重复数据的行.rar (7.73 KB, 下载次数: 28)

2013-12-28 11:25 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-12-28 13:29

1. Sub 删除选定列有重复数据的行()
   
2.     Dim x As Range
   
3.     On Error Resume Next
   
4.     Set x = Application.InputBox(prompt:="请选择要操作的列或者列区域", Title:="提示", Default:="请选择", Type:=8)
   
5.     If x Is Nothing Then Exit Sub
   
6.     If x.Rows.Count = 1 Then Exit Sub
   
7.     '忽略多区域
   
8.     If x.Areas.Count > 1 Then Exit Sub
   
9.     '忽略只有一选数据的区域
   
10.     arr = x.Value
    
11.     Dim rg As Range, dic As Object
    
12.     Set dic = CreateObject("scripting.dictionary")
    
13.     Application.ScreenUpdating = False
    
14.     For i = UBound(arr) To LBound(arr) Step -1
    
15.         If dic.Exists(arr(i, 1)) Then
    
16.             If rg Is Nothing Then
    
17.                 Set rg = x.Rows(i).EntireRow
    
18.             Else
    
19.                 Set rg = Union(rg, x.Rows(i).EntireRow)
    
20.             End If
    
21.         Else
    
22.             dic.Add arr(i, 1), ""
    
23.         End If
    
24.     Next
    
25.     If Not rg Is Nothing Then rg.Delete
    
26.     Application.ScreenUpdating = True
    
27.     Set dic = Nothing
    
28. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 删除选定列有重复数据的行()
   
2.     Dim x As Range
   
3.     On Error Resume Next
   
4.     Set x = Application.InputBox(prompt:="请选择要操作的列或者列区域", Title:="提示", Default:="请选择", Type:=8)
   
5.     If x Is Nothing Then Exit Sub
   
6.     If x.Rows.Count = 1 Then Exit Sub
   
7.     '忽略多区域
   
8.     If x.Areas.Count > 1 Then Exit Sub
   
9.     '忽略只有一选数据的区域
   
10.     arr = x.Value
    
11.     Dim rg As Range, dic As Object
    
12.     Set dic = CreateObject("scripting.dictionary")
    
13.     Application.ScreenUpdating = False
    
14.     For i = UBound(arr) To LBound(arr) Step -1
    
15.         If dic.Exists(arr(i, 1)) Then
    
16.             If rg Is Nothing Then
    
17.                 Set rg = x.Rows(i).EntireRow
    
18.             Else
    
19.                 Set rg = Union(rg, x.Rows(i).EntireRow)
    
20.             End If
    
21.         Else
    
22.             dic.Add arr(i, 1), ""
    
23.         End If
    
24.     Next
    
25.     If Not rg Is Nothing Then rg.Delete
    
26.     Application.ScreenUpdating = True
    
27.     Set dic = Nothing
    
28. End Sub

复制代码

yjwdjfqb

hwc2ycy 发表于 2013-12-28 13:29

感谢老师的帮助！