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经典代码实践指南
查看: 359|回复: 9

[求助] 求合并表格,按照条件顺序去重复代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-12 22:17 | 显示全部楼层 |阅读模式
请求大神帮忙写个VBA,逻辑如下
1.将附件 1 2 3 的excel表格自动合并成一份完整的表格
2.按照K列 钻>金>银>铜 的条件顺序删除A类的重复号码,如 K列的钻与金有重复的号码,保留钻的号码,删除金的重复号码
当钻与铜有重复号码时,保留钻的号码,删除铜的号码,当银与铜重复号码时,删除铜保留银,最后都A列无重复单号

123.7z

14.33 KB, 下载次数: 5

材料

TA的精华主题

TA的得分主题

发表于 2019-1-13 06:07 | 显示全部楼层
  1. Sub dsmch()
  2. Dim arr, brr, d, w, i&, s&, j%
  3. w = Array("钻", "金", "银", "铜")
  4. Set d = CreateObject("scripting.dictionary")
  5. ReDim brr(1 To 20000, 1 To 12)
  6. Range("a2:l20000").ClearContents
  7. mypath = ThisWorkbook.Path & ""
  8. wj = Dir(mypath & "*.xls*")
  9. Do While wj <> ""
  10.     If wj <> ThisWorkbook.Name Then
  11.         With GetObject(mypath & wj)
  12.             arr = .Sheets(1).Range("a1").CurrentRegion
  13.             .Close 0
  14.         End With
  15.         For i = 2 To UBound(arr)
  16.             If Not d.exists(arr(i, 11)) Then
  17.                 d(arr(i, 11)) = ""
  18.                 Set d(arr(i, 11)) = CreateObject("scripting.dictionary")
  19.             End If
  20.             If Not d(arr(i, 11)).exists(arr(i, 1)) Then d(arr(i, 11))(arr(i, 1)) = i
  21.         Next
  22.         For i = 0 To UBound(w)
  23.             For Each b In d(w(i)).items
  24.                 If Not d.exists(arr(b, 1)) Then
  25.                     d(arr(b, 1)) = ""
  26.                     s = s + 1
  27.                     For j = 1 To UBound(arr, 2)
  28.                         brr(s, j) = arr(b, j)
  29.                     Next
  30.                 End If
  31.             Next
  32.         Next
  33.     End If
  34.     wj = Dir
  35. Loop
  36. Range("a2").Resize(s, UBound(brr, 2)) = brr
  37. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2019-1-13 06:07 | 显示全部楼层
………………

123.rar

40.42 KB, 下载次数: 3

TA的精华主题

TA的得分主题

发表于 2019-1-13 06:11 | 显示全部楼层
论坛缺陷,第7句代码“\”缺失
mypath = ThisWorkbook.Path & "\"

评分

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

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-13 22:24 | 显示全部楼层
dsmch 发表于 2019-1-13 06:11
论坛缺陷,第7句代码“\”缺失
mypath = ThisWorkbook.Path & "\"

大神,可不可以A列是一开始就是保转化为文本格式去重复的,因为号码第一位数字有可能是0,然后按条件合并去重之后,如果钻与钻之间还存在重复的号码也是要去重复的

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-13 22:41 | 显示全部楼层
540872759 发表于 2019-1-13 22:24
大神,可不可以A列是一开始就是保转化为文本格式去重复的,因为号码第一位数字有可能是0,然后按条件合并 ...

如图片般,A列号码为文本格式,且K列相同条件也无重复值

TA的精华主题

TA的得分主题

发表于 2019-1-14 05:41 | 显示全部楼层
540872759 发表于 2019-1-13 22:24
大神,可不可以A列是一开始就是保转化为文本格式去重复的,因为号码第一位数字有可能是0,然后按条件合并 ...

上传附件模拟一下结果

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-14 21:30 | 显示全部楼层
dsmch 发表于 2019-1-14 05:41
上传附件模拟一下结果

请查看压缩包中的图片,结果就如图片所示

345.zip

38.09 KB, 下载次数: 1

345

TA的精华主题

TA的得分主题

发表于 2019-1-14 22:15 | 显示全部楼层
For i = 2 To UBound(arr)
            arr(i, 1) = "'" & arr(i, 1)
            If Not d.exists(arr(i, 11)) Then
                d(arr(i, 11)) = ""

评分

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

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-19 13:01 | 显示全部楼层
dsmch 发表于 2019-1-14 22:15
For i = 2 To UBound(arr)
            arr(i, 1) = "'" & arr(i, 1)
            If Not d.exists(arr( ...

Sub dsmch()
Dim arr, brr, d, w, i&, s&, j%
w = Array("钻", "金", "银", "铜")
Set d = CreateObject("scripting.dictionary")
ReDim brr(1 To 20000, 1 To 12)
Range("a2:l20000").ClearContents
mypath = ThisWorkbook.Path & "\"
wj = Dir(mypath & "*.xls*")
Do While wj <> ""
    If wj <> ThisWorkbook.Name Then
        With GetObject(mypath & wj)
            arr = .Sheets(1).Range("a1").CurrentRegion
            .Close 0
        End With
        For i = 2 To UBound(arr)
        arr(i, 1) = "'" & arr(i, 1)
            If Not d.exists(arr(i, 11)) Then
                d(arr(i, 11)) = ""
                Set d(arr(i, 11)) = CreateObject("scripting.dictionary")
            End If
            If Not d(arr(i, 11)).exists(arr(i, 1)) Then d(arr(i, 11))(arr(i, 1)) = i
        Next
        For i = 0 To UBound(w)
            For Each b In d(w(i)).items
                If Not d.exists(arr(b, 1)) Then
                    d(arr(b, 1)) = ""
                    s = s + 1
                    For j = 1 To UBound(arr, 2)
                        brr(s, j) = arr(b, j)
                    Next
                End If
            Next
        Next
    End If
    wj = Dir
Loop
Range("a2").Resize(s, UBound(brr, 2)) = brr
End Sub



放入了以上的代码,然后文档里面有7个excel文档,运行代码是出现“运行时错误9 下标越界 ” 的提示,请问是缺了什么吗
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2019-10-20 20:15 , Processed in 0.082607 second(s), 21 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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