ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 308|回复: 7

[分享] VBA去除重复数据

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-1 22:02 | 显示全部楼层 |阅读模式
在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. 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
复制代码
我总觉得我的笨办法还能更简化一些,可是就是不知道该如何精简。请各位大神指正。

去除重复数据行.zip

19.02 KB, 下载次数: 25

评分

参与人数 1鲜花 +2 收起 理由
zpy2 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-2 09:48 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-2 10:08 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-2 10:17 | 显示全部楼层
  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. Sub SQL去重()
  25.     Dim oConn As Object, sSQL As String
  26.    
  27.     Set oConn = CreateObject("Adodb.Connection")
  28.     oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接
  29.     sSQL = "Select [科目],[教师] From [Sheet1$] Group By [科目],[教师]"
  30.     With Sheet3
  31.         .UsedRange.Offset(1).Delete shift:=xlup
  32.         .[A2].CopyFromRecordset oConn.Execute(sSQL) '执行语句并赋值到某个起始单元格
  33.     End With
  34. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
FOB_FN_L + 2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-2 10:18 | 显示全部楼层
字典去重、SQL去重的两个方法

去除重复数据行(by.micro).rar

21.23 KB, 下载次数: 23

评分

参与人数 1鲜花 +2 收起 理由
1055751654 + 2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-2 10:45 | 显示全部楼层
任意列,整行去重。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

评分

参与人数 1鲜花 +2 收起 理由
FOB_FN_L + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-2 19:12 | 显示全部楼层
microyip 发表于 2019-12-2 10:18
字典去重、SQL去重的两个方法

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

TA的精华主题

TA的得分主题

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

一直不是太熟悉字典的使用,跟你学习了。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-12-10 01:57 , Processed in 1.415932 second(s), 33 queries , Gzip On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表