VBA去除重复数据

水无鱼

在EXCEL数据统计中，有时候需要去除重复数据行。在此分享一下我的一个笨办法。

1. Sub 去重()
   
2.     Dim arr(), brr(), crr()
   
3.     Dim i, j, k, l
   
4.         
   
5.     On Error Resume Next
   
6.         
   
7.     arr = Sheet1.Cells(1, 1).CurrentRegion.Value    '将工作表1中的原始数据赋给arr数组
   
8.     ReDim brr(1 To UBound(arr), 1 To 3)     '定义brr数组，比arr多一列
   
9.     rs = UBound(arr)    '取数组arr的最后一行
   
10.    
    
11.     For i = 1 To rs
    
12.         brr(i, 1) = arr(i, 1): brr(i, 2) = arr(i, 2): brr(i, 3) = 0     '将arr数组赋给brr，第3列作为判断重复列，赋初始值0
    
13.     Next
    
14.         
    
15.     For i = 2 To rs
    
16.         For j = i + 1 To rs
    
17.             If brr(j, 1) = brr(i, 1) And brr(j, 2) = brr(i, 2) Then brr(j, 3) = 1   '从第3行开始brr中出现和重复行时，判断重复列赋值为1
    
18.         Next
    
19.     Next
    
20.    
    
21.     k = 0
    
22.     For i = 2 To rs
    
23.             If brr(i, 3) = 1 Then k = k + 1 '统计重复数据行数
    
24.     Next
    
25.    
    
26.     ReDim crr(1 To rs - k, 1 To 2)  '定义crr数据
    
27.     l = 1
    
28.     For i = 1 To rs
    
29.         If brr(i, 3) = 0 Then
    
30.             crr(l, 1) = brr(i, 1): crr(l, 2) = brr(i, 2)    '将不重复数据赋值给crr数据
    
31.             l = l + 1
    
32.         End If
    
33.     Next
    
34.    
    
35.     Sheet2.Cells(1, 1).Resize(UBound(crr), 2) = crr '在表2中写出原始数据中所有不重复的数据
    
36. 
    
37. End Sub

复制代码

当然还有一个简便办法。

1. Sub 去重1()
   
2.     arr = Sheet1.Cells(1, 1).CurrentRegion.Value    '将工作表1中的原始数据赋给arr数组
   
3.     Sheet3.Cells(1, 1).Resize(UBound(arr), 2) = arr '在表3中重新写出原始数据
   
4.     Sheet3.Range("A1:B" & UBound(arr)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
   
5. End Sub
   

复制代码

我总觉得我的笨办法还能更简化一些，可是就是不知道该如何精简。请各位大神指正。

Q155133209

你怕是不知道 字典

chis3

你是想分享思路還是不懂有字典?

microyip

1. Sub 字典去重()
   
2.     Dim vData As Variant, nRow As Long, vKey As Variant
   
3.     Dim oDic As Object
   
4.    
   
5.     Set oDic = CreateObject("Scripting.Dictionary") '设置oDic为字典
   
6.     With Sheet1.UsedRange
   
7.         vData = .Offset(1).resize(.Rows.Count - 1).Value
   
8.     End With
   
9.     For nRow = 1 To UBound(vData)
   
10.         vKey = vData(nRow, 1) & "|" & vData(nRow, 2) '建立关键字
    
11.         If Not oDic.Exists(vKey) Then '判断字典里不存在关键字
    
12.             oDic(vKey) = oDic.Count + 1 '建立vKey关键字的字典，字典值为字典关键字数量+1
    
13.             If nRow <> oDic.Count Then '当行数不等于字典关键字数量时，重写到数组里
    
14.                 vData(oDic.Count, 1) = vData(nRow, 1)
    
15.                 vData(oDic.Count, 2) = vData(nRow, 2)
    
16.             End If
    
17.         End If
    
18.     Next
    
19.     With Sheet3
    
20.         .UsedRange.Offset(1).Delete shift:=xlup
    
21.         .[A2].resize(oDic.Count, UBound(vData, 2)) = vData
    
22.     End With
    
23. End Sub
    
24. 
    
25. Sub SQL去重()
    
26.     Dim oConn As Object, sSQL As String
    
27.    
    
28.     Set oConn = CreateObject("Adodb.Connection")
    
29.     oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接
    
30.     sSQL = "Select [科目],[教师] From [Sheet1$] Group By [科目],[教师]"
    
31.     With Sheet3
    
32.         .UsedRange.Offset(1).Delete shift:=xlup
    
33.         .[A2].CopyFromRecordset oConn.Execute(sSQL) '执行语句并赋值到某个起始单元格
    
34.     End With
    
35. End Sub

复制代码

microyip

字典去重、SQL去重的两个方法

liangmutou01

任意列，整行去重。f 欲去重的单元格区域，m 放置结果的单元格位置，调用即可。
Sub qc(f As Range, m As Range)
  Application.ScreenUpdating = False
  Set d = CreateObject("scripting.dictionary")
  ar = f
  For h = 1 To UBound(ar)
    For lie = 1 To UBound(ar, 2)
      ls = ls & "??" & ar(h, lie)
    Next lie
    d(ls) = ""
    ls = ""
  Next h
  ReDim br(1 To d.Count, 1 To UBound(ar, 2))
  h = 0
  For Each b In d.keys
    h = h + 1
    ls = Split(b, "??")
    For lie = 1 To UBound(ls)
      br(h, lie) = ls(lie)
    Next lie
  Next b
  m.Resize(d.Count, UBound(ar, 2)) = br
  Set d = Nothing
  Application.ScreenUpdating = True
End Sub

水无鱼

microyip 发表于 2019-12-2 10:18
字典去重、SQL去重的两个方法

谢谢指教。字典的使用一直不是太熟悉。跟你学习了。

水无鱼

liangmutou01 发表于 2019-12-2 10:45
任意列，整行去重。f 欲去重的单元格区域，m 放置结果的单元格位置，调用即可。
Sub qc(f As Range, m As  ...

一直不是太熟悉字典的使用，跟你学习了。