ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

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

[求助] 如何用VBA剔除列表中的重复项及求和

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-10-17 13:12 | 显示全部楼层 |阅读模式
问题如下:
1017-1.JPG

如何用VBA剔除重复项及求和.zip

9.74 KB, 下载次数: 12

TA的精华主题

TA的得分主题

发表于 2020-10-17 14:11 | 显示全部楼层
將下面的"....."都刪去
Sub TEST_A1()
Dim Arr, xD, i&, j%, T1$, T2$, N&, R&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([D1], [A65536].End(3)): N = 1
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3)
    T2 = T1 & "|" & Arr(i, 4)
    xD(T2) = xD(T2) + 1: If xD(T2) > 1 Then GoTo i01
    R = xD(T1)
    If R > 0 Then Arr(R, 4) = Arr(R, 4) + Arr(i, 4): GoTo i01
    N = N + 1: R = N: xD(T1) = N
    For j = 1 To 4: Arr(R, j) = Arr(i, j): Next
i01: Next i
With [J1].Resize(N, 4)
     .Value = Arr
     For j = 3 To 1 Step -1
        .Sort Key1:=.Item(j), Order1:=xlAscending, Header:=xlYes
     Next j
End With
End Sub


评分

参与人数 2鲜花 +4 收起 理由
hongshan2019 + 2 优秀作品
mai51 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-10-17 14:23 | 显示全部楼层
本帖最后由 cui26896 于 2020-10-17 15:52 编辑

Sub test()
Dim arr, brr, d, d2, i%, j%, j2%, k, k2, s
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  arr = Sheets(1).Range("a1:d" & Sheets(1).UsedRange.Rows.Count)
  ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  For i = 2 To UBound(arr)
    s = vbNullString
    For j = 1 To UBound(arr, 2)
      If j < UBound(arr, 2) Then
        s = s & arr(i, j) & "|"
        Else
          s = s & arr(i, j)
      End If
    Next
      If arr(i, 1) <> "……" And Not d.exists(s) Then
        k = k + 1
        d(s) = k
        For j = 1 To UBound(arr, 2)
          brr(d(s), j) = arr(i, j)
        Next
      End If
  Next
    ReDim arr(1 To k, 1 To UBound(brr, 2))
    For i = 1 To k
      s = vbNullString
      For j = 1 To UBound(brr, 2)
        If j < UBound(brr, 2) - 1 Then
          s = s & brr(i, j) & "|"
          Else
            s = s & brr(i, j)
        End If
      Next
        If d2.exists(s) = False Then
          k2 = k2 + 1
          d2(s) = k2
          For j2 = 1 To UBound(brr, 2)
            arr(d2(s), j2) = brr(i, j2)
          Next
            Else
              arr(d2(s), 4) = arr(d2(s), 4) + brr(i, 4)
        End If
    Next
  With Sheets(1)
    .Range("o2").Resize(k2+1, UBound(arr, 2)) = arr
    .Range("o2:r" & k2+1).Sort key1:=.Range("q2"), order1:=xlAscending, Header:=xlNo
    .Range("o2:r" & k2+1).Sort key1:=.Range("p2"), order1:=xlAscending, Header:=xlNo
    .Range("o2:r" & k2+1).Sort key1:=.Range("o2"), order1:=xlAscending, Header:=xlNo
  End With
End Sub

TA的精华主题

TA的得分主题

发表于 2020-10-17 14:25 | 显示全部楼层
本帖最后由 cui26896 于 2020-10-17 15:18 编辑

要审核,先发附件,请参考
如何用VBA剔除重复项及求和.zip (18.86 KB, 下载次数: 14)

评分

参与人数 1鲜花 +2 收起 理由
mai51 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-17 15:03 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-10-17 15:19 | 显示全部楼层
mai51 发表于 2020-10-17 15:03
老师,这结果怎么不对呀?见下图。

排序漏了最后一行,重新上传了附件,请下载新的附近件。

TA的精华主题

TA的得分主题

发表于 2020-10-17 15:20 | 显示全部楼层
用sql会不会简单点?

如何用VBA剔除重复项及求和.rar

11.36 KB, 下载次数: 8

TA的精华主题

TA的得分主题

发表于 2020-10-17 15:40 | 显示全部楼层
第一、二部字典可一次搞定,第三四部排序搞定

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-17 16:16 | 显示全部楼层
无敌小猪猪 发表于 2020-10-17 15:20
用sql会不会简单点?

这要外部链接,还是用VBA吧,处理时间应该不会快多少

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-17 17:52 | 显示全部楼层
本帖最后由 mai51 于 2020-10-17 18:01 编辑
cui26896 发表于 2020-10-17 15:19
排序漏了最后一行,重新上传了附件,请下载新的附近件。

老师,有个小问题帮忙追加一下,就是D列求和结果四舍五入只保留整数位,不要小数位了。我不太懂编码,劳烦老师帮忙修改一下。
1017-3.JPG
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

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

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

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

GMT+8, 2020-10-30 20:37 , Processed in 0.110952 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

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

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

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