有偿求助删除多余重复数据

yudis98s

我现在表格里面有二列数据，其中B列有重复的数据，比如B列有重复的数据，A列没有重复，那么我需要把跟B列重复的数据对应的A列中的数据也删除，附加文件里面我的表格数据，请高手帮忙看下，可以有偿

opel-wong

这活不难，我接了，已发消息给你。

liulang0808

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Application.Intersect(Columns("a:b"), ActiveSheet.UsedRange)
   
4.     r = 0
   
5.     For j = 1 To UBound(arr)
   
6.         If Not d.exists(arr(j, 2)) And Len(arr(j, 2)) > 0 Then
   
7.             r = r + 1
   
8.             For i = 1 To 2
   
9.                 arr(r, i) = arr(j, i)
   
10.             Next i
    
11.             d(arr(j, 2)) = ""
    
12.         End If
    
13.     Next j
    
14.     [j2].Resize(r, 2) = arr
    
15. End Sub
    

复制代码

liulang0808

一个简单的字典处理

opel-wong

很简单的代码，楼主的数据量很大，初步估计有10万行。
所以，就没有通过字典转置输出的方式，而是采用装入数组再输出的方式。
现贴出来吧，

1. Sub 删除重复数据()
   
2.     Dim arr, ZR(), i As Long, m As Long: m = 0
   
3.     Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Worksheets("数据源").UsedRange.Value
   
5.     ReDim ZR(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 1 To UBound(arr)
   
7.         If Len(arr(i, 2)) > 0 And Not d.Exists(arr(i, 2)) Then
   
8.             d(arr(i, 2)) = ""
   
9.             m = m + 1
   
10.             ZR(m, 1) = arr(i, 1)
    
11.             ZR(m, 2) = arr(i, 2)
    
12.         End If
    
13.     Next
    
14.     With Worksheets("结果")
    
15.         .Activate
    
16.         .Cells.ClearContents
    
17.         .Range("A2").Resize(m, UBound(arr, 2)).Value = ZR
    
18.     End With
    
19.     Set d = Nothing
    
20. End Sub
    

复制代码