在指定的一个或多个单元格区域内，把完全相同的单元格全部都清空，如果只保留一个

Vicel

gaoch35 发表于 2014-12-2 10:34
如果我想指定两个或多个单元格区域，不是列，比如两个单元格区域为a3:b17和c5:e21,那代码怎么改

直接选任意区域

1. Sub SC()
   
2.     Dim rng() As String, cell As Range, rngtemp As Range
   
3.     Application.ScreenUpdating = False
   
4.     AD = Selection.Address(0, 0)
   
5.     rng = Split(AD, ",")
   
6.     For Each cell In Selection
   
7.         s = 0
   
8.         T = cell.Value
   
9.         If T = "" Then
   
10.             GoTo 1         '单元格值为空直接往下一单元格
    
11.         ElseIf Trim(T) <> "" Then
    
12.             For Each rn In rng
    
13.                 s = s + Application.CountIf(Range(rn), T)
    
14.             Next
    
15.         Else
    
16.             cell.Value = ""
    
17.         End If
    
18.         If s > 1 Then
    
19.             Selection.Find(What:=T, After:=ActiveCell, LookIn _
    
20.             :=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
    
21.             xlNext, MatchCase:=False, SearchFormat:=False).Activate
    
22.             Do
    
23.                 Selection.FindNext(After:=ActiveCell).Delete Shift:=xlUp
    
24.                 s = s - 1
    
25.             Loop While s > 1
    
26.         End If
    
27. 1:  Next
    
28.     Application.ScreenUpdating = True
    
29. End Sub

复制代码

gaoch35

Vicel 发表于 2014-12-2 13:20
直接选任意区域

用第20楼的代码时会多删除一个没有重复的单元格，如果把第20楼的代码改成把全部完全相同的单元格都删除掉，会多删除两个没有重复的单元格

gaoch35

Vicel 发表于 2014-12-2 13:20
直接选任意区域

第21楼的单元格区域在哪？一个或多个单元格区域怎么填

Vicel

gaoch35 发表于 2014-12-2 22:35
第21楼的单元格区域在哪？一个或多个单元格区域怎么填

21 楼代码是你先选中需要操作的区域，再去执行代码就行

Vicel

gaoch35 发表于 2014-12-2 22:24
用第20楼的代码时会多删除一个没有重复的单元格，如果把第20楼的代码改成把全部完全相同的单元格都删除掉 ...

楼主不模拟结果给我看，我无法判断代码是否有问题。

非整列的区域选择，区间范围是固定不变的。当你删掉一个符合条件的单元格后，临近的单元格会填补进去，或许那个单元格刚好也符合条件，然后也被判断而删除掉。

如果想避免这种情况，最好是把符合条件的单元格清空，而不是直接删除

gaoch35

Vicel 发表于 2014-12-3 09:28
楼主不模拟结果给我看，我无法判断代码是否有问题。

非整列的区域选择，区间范围是固定不变的。当你删 ...

怎么清空，请编写一份吧，拜托了

hacker85

@gaoch35  我觉得你没有看懂Vicel的话，他是让你把你所有要求用1、2、3……的形式，一条一条的叙述清楚，并在excel表格里配上数据前、后的例子，这样他会知道具体怎么做，会把情况考虑周全。

@Vicel，佩服你，真有耐心，我都被楼主变来变去的要求弄混了，你却还依然“清晰”着，学习。

PS：如若我总结不错，楼主是希望这样一个功能：
编写一个VBA，最好带有窗体形式，用来填入单元格任意区域，形如a1:c5;d2:e9……用来删除指定的任意区域内单元格内容重复的内容，留下唯一。任意单元格区域包含一整列形式，还包含不连续的多个整列形式，也包含任意大小的单元格区域。

因为看到Vicel在删除重复内容方面的经验，这里可以延展一个问题，如果多个任意区域的选取或者是窗体输入，导致出现“交叉”区域怎么办？而恰恰交叉区域内也存在重复内容。

gaoch35

Vicel 发表于 2014-12-3 09:18
21 楼代码是你先选中需要操作的区域，再去执行代码就行

麻烦一下，去看看1楼写的，编写出vba
拜托了，谢谢

Vicel

hacker85 发表于 2014-12-3 09:49
@gaoch35  我觉得你没有看懂Vicel的话，他是让你把你所有要求用1、2、3……的形式，一条一条的叙述清楚，并 ...

区域可自由更改，能处理交叉单元格问题，可选择清空或删除多余重复单元格

1. Sub SC()
   
2.    
   
3.     Dim rng As Range, cell As Range, d As Object, dd As Object, s As Integer, n As Integer, Z As String, T As String
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set dd = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     rng1 = "A1: C5"
   
8.     rng2 = "C2: E9"
   
9.     rng3 = "A22:E28"
   
10.     Union(Range(rng1), Range(rng2), Range(rng3)).Select
    
11.     s = 0: n = 0
    
12.     For Each cell In Selection
    
13.         Z = cell.Address(0, 0)
    
14.         T = cell.Value
    
15.         If Not d.exists(Z) Then
    
16.             s = s + 1
    
17.             d.Add Z, T
    
18.             If T = "" Then
    
19.                 GoTo 1         '单元格值为空直接往下一单元格
    
20.             ElseIf Trim(T) <> "" Then
    
21.                 If Not dd.exists(T) Then
    
22.                     dd.Add T, Z
    
23.                     K = dd.Item(T)
    
24.                 ElseIf Z <> dd.Item(T) Then
    
25.                     n = n + 1
    
26.                     If rng Is Nothing Then
    
27.                         Set rng = cell
    
28.                     Else
    
29.                         Set rng = Union(rng, cell)
    
30.                     End If
    
31.                 End If
    
32.             Else
    
33.                 cell.Value = ""
    
34.             End If
    
35.         Else
    
36.             GoTo 1             '单元格为已查询过的，直接往下一单元格
    
37.         End If
    
38. 1:  Next
    
39.     d.RemoveAll
    
40.     rng.Select
    
41.     Selection.Delete Shift:=xlUp       '删除重复单元格，或换下面代码清空重复单元格
    
42.     'Selection.Clear
    
43.     'MsgBox "共选择了" & s & "个单元格，其中" & n & "个重复单元格已被清空"
    
44.     Application.ScreenUpdating = True
    
45.    
    
46. End Sub

复制代码

或直接在表格里选择所需操作区域，再执行下列代码

1. Sub SC()
   
2.    
   
3.     Dim rng As Range, cell As Range, d As Object, dd As Object, s As Integer, n As Integer, Z As String, T As String
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set dd = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     s = 0: n = 0
   
8.     For Each cell In Selection
   
9.         Z = cell.Address(0, 0)
   
10.         T = cell.Value
    
11.         If Not d.exists(Z) Then
    
12.             s = s + 1
    
13.             d.Add Z, T
    
14.             If T = "" Then
    
15.                 GoTo 1         '单元格值为空直接往下一单元格
    
16.             ElseIf Trim(T) <> "" Then
    
17.                 If Not dd.exists(T) Then
    
18.                     dd.Add T, Z
    
19.                     K = dd.Item(T)
    
20.                 ElseIf Z <> dd.Item(T) Then
    
21.                     n = n + 1
    
22.                     If rng Is Nothing Then
    
23.                         Set rng = cell
    
24.                     Else
    
25.                         Set rng = Union(rng, cell)
    
26.                     End If
    
27.                 End If
    
28.             Else
    
29.                 cell.Value = ""
    
30.             End If
    
31.         Else
    
32.             GoTo 1             '单元格为已查询过的，直接往下一单元格
    
33.         End If
    
34. 1:  Next
    
35.     d.RemoveAll
    
36.     rng.Select
    
37.     Selection.Delete Shift:=xlUp       '删除重复单元格，或换下面代码清空重复单元格
    
38.     'Selection.Clear
    
39.     'MsgBox "共选择了" & s & "个单元格，其中" & n & "个重复单元格已被清空"
    
40.     Application.ScreenUpdating = True
    
41.    
    
42. End Sub
    

复制代码

删除重复.rar (9.4 KB, 下载次数: 18)

2014-12-3 12:06 上传

点击文件名下载附件

Vicel

先选择需操作区域，再执行代码。可全部清空重复单元格，或只保留一个

1. 
   
2. Sub QK()           '清空重复单元格
   
3.    
   
4.     Dim rng As Range, cell As Range, d As Object, dd As Object, Z As String, T As String
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set dd = CreateObject("scripting.dictionary")
   
7.     Application.ScreenUpdating = False
   
8.     For Each cell In Selection
   
9.         Z = cell.Address(0, 0)
   
10.         T = cell.Value
    
11.         If Not d.exists(Z) Then
    
12.             d.Add Z, T
    
13.             If T = "" Then
    
14.                 GoTo 1         '单元格值为空直接往下一单元格
    
15.             ElseIf Trim(T) <> "" Then
    
16.                 If Not dd.exists(T) Then
    
17.                     dd.Add T, Z
    
18.                     K = dd.Item(T)
    
19.                 ElseIf Z <> dd.Item(T) Then
    
20.                     Range(dd.Item(T)).Clear         '省略此行代码，则重复单元格只保留一个
    
21.                     If rng Is Nothing Then
    
22.                         Set rng = cell
    
23.                     Else
    
24.                         Set rng = Union(rng, cell)
    
25.                     End If
    
26.                 End If
    
27.             Else
    
28.                 cell.Value = ""
    
29.             End If
    
30.         Else
    
31.             GoTo 1             '单元格为已查询过的，直接往下一单元格
    
32.         End If
    
33. 1:  Next
    
34.     d.RemoveAll
    
35.     rng.Select
    
36.     Selection.Clear
    
37.     Application.ScreenUpdating = True
    
38.    
    
39. End Sub

复制代码