[已解决]求助：VBA药品去重复

yjwdjfqb

求助：VBA药品去重复

当运行，VBA时，弹出一选择框，按住CTRL键，可以选择多列(可以选择一列，也可以选择多列)。

确定后，删除，这些列重复的行。

请高手老师们帮帮忙，谢谢大家了!
VBA药品去重复.rar (34.42 KB, 下载次数: 26)

2014-10-6 10:18 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2014-10-6 11:05

1. Sub 多列选择去重复()
   
2.     Dim rng As Range, arr, area, i%, j%, k%, d As Object
   
3.     On Error Resume Next
   
4.     Set rng = Application.InputBox("请按CTRL选择需要去重复的列", "选择", , , , , , 8)
   
5.     If rng Is Nothing Then Exit Sub
   
6.     If rng.Rows.Count = 1 Then
   
7.         Exit Sub
   
8.     Else
   
9.         ReDim arr(1 To rng.Areas.Count)
   
10.         For i = 1 To rng.Areas.Count
    
11.             arr(i) = Intersect(ActiveSheet.UsedRange, rng.Areas(i)).Value
    
12.         Next
    
13.         Set d = CreateObject("scripting.dictionary")
    
14.         Set rng = Nothing
    
15.         For i = 2 To UBound(arr(1))
    
16.             For j = 1 To UBound(arr)
    
17.                 For k = 1 To UBound(arr(j), 2)
    
18.                      sr = sr & arr(j)(i, k)
    
19.                 Next
    
20.             Next
    
21.             If d.exists(sr) Then
    
22.                 If rng Is Nothing Then Set rng = Rows(i) Else Set rng = Union(rng, Rows(i))
    
23.             Else: d(sr) = ""
    
24.             End If
    
25.             sr = ""
    
26.         Next
    
27.     End If
    
28.     rng.Delete
    
29. End Sub

复制代码

如果需要保留从上到下第一个不重复的，那就用这个吧

跳转到最佳答案楼层

xdragon

1. Sub 多列选择去重复()
   
2.     Dim rng As Range, arr, area, i%, j%, k%, d As Object
   
3. 
   
4.     On Error Resume Next
   
5.     Set rng = Application.InputBox("请按CTRL选择需要去重复的列", "选择", , , , , , 8)
   
6.     If rng Is Nothing Then Exit Sub
   
7.     If rng.Rows.Count = 1 Then
   
8.         Exit Sub
   
9.     Else
   
10.         ReDim arr(1 To rng.Areas.Count)
    
11.         For i = 1 To rng.Areas.Count
    
12.             arr(i) = Intersect(ActiveSheet.UsedRange, rng.Areas(i)).Value
    
13.         Next
    
14.         Set d = CreateObject("scripting.dictionary")
    
15.         For i = UBound(arr(1)) To 2 Step -1
    
16.             sr = ""
    
17.             For j = 1 To UBound(arr)
    
18.                 For k = 1 To UBound(arr(j), 2)
    
19.                      sr = sr & arr(j)(i, k)
    
20.                 Next
    
21.             Next
    
22.             If d.exists(sr) Then Rows(i).Delete Else d(sr) = ""
    
23.         Next
    
24.     End If
    
25. End Sub

复制代码

yjwdjfqb

xdragon 发表于 2014-10-6 10:55

谢谢老师了，你太厉害了，

有重复的数据，是不是，保留的第一次出现的数据呀

我测试下，太感谢你了老师!

xdragon

1. Sub 多列选择去重复()
   
2.     Dim rng As Range, arr, area, i%, j%, k%, d As Object
   
3.     On Error Resume Next
   
4.     Set rng = Application.InputBox("请按CTRL选择需要去重复的列", "选择", , , , , , 8)
   
5.     If rng Is Nothing Then Exit Sub
   
6.     If rng.Rows.Count = 1 Then
   
7.         Exit Sub
   
8.     Else
   
9.         ReDim arr(1 To rng.Areas.Count)
   
10.         For i = 1 To rng.Areas.Count
    
11.             arr(i) = Intersect(ActiveSheet.UsedRange, rng.Areas(i)).Value
    
12.         Next
    
13.         Set d = CreateObject("scripting.dictionary")
    
14.         Set rng = Nothing
    
15.         For i = 2 To UBound(arr(1))
    
16.             For j = 1 To UBound(arr)
    
17.                 For k = 1 To UBound(arr(j), 2)
    
18.                      sr = sr & arr(j)(i, k)
    
19.                 Next
    
20.             Next
    
21.             If d.exists(sr) Then
    
22.                 If rng Is Nothing Then Set rng = Rows(i) Else Set rng = Union(rng, Rows(i))
    
23.             Else: d(sr) = ""
    
24.             End If
    
25.             sr = ""
    
26.         Next
    
27.     End If
    
28.     rng.Delete
    
29. End Sub

复制代码

如果需要保留从上到下第一个不重复的，那就用这个吧

yjwdjfqb

xdragon 发表于 2014-10-6 11:05
如果需要保留从上到下第一个不重复的，那就用这个吧

谢谢老师了，你太厉害了，谢谢了!

526753064

xdragon 发表于 2014-10-6 10:55

请教一下。arr(j)(i, k)，这个是数组的什么格式，属于几维数组

xdragon

526753064 发表于 2014-10-6 11:24
请教一下。arr(j)(i, k)，这个是数组的什么格式，属于几维数组

arr是一维数组,每个arr(j)下面包含的各是一个二维数组。就是一个一维数组里面有n个二维数组的意思。