ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1853|回复: 14

[求助] 字典中的关键字是唯一的,却遇到一个问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-1-23 19:00 | 显示全部楼层 |阅读模式
Sub defg()
Set d =CreateObject("scripting.dictionary")
Set d1 =CreateObject("scripting.dictionary")
   Application.ScreenUpdating = False
    c= Cells(1, Columns.Count).End(xlToLeft).Column + 1
    r= Cells(Rows.Count, 1).End(3).Row + 1
   arr = Sheets(2).UsedRange
   For i = 2 To UBound(arr)
       d(arr(i, 1)) = i
   Next
   arr = Sheets(1).UsedRange
   For i = 2 To UBound(arr)
       d1(arr(i, 1)) = d1(arr(i, 1)) + arr(i, 2)
   Next
   brr = d1.Keys
   Sheets(1).Activate
   [c2].Resize(d.Count, 1) = Application.Transpose(brr)
   Sheets(2).Activate
   For j = 0 To UBound(brr)
           If d.exists(brr(j)) Then
                Cells(d(brr(j)), c) =d1.Item(brr(j))
           Else
                Cells(r, 1) = brr(j): Cells(r,c) = d1.Item(brr(j)): r = r + 1
           End If
   Next
End Sub

关键字唯一的问题:想通过字典d1把sheet1中A列的重复项去掉,把相应的B列数据相加,如果sheet2中已经有这一项就把数据写进相应的B列中,而sheet2中没有这一项就在最后一行的A加上这一项和B列相应的数据。但现在遇到问题,例如sheet2中已经有ousm(5894行)为什么还会在后面加上一行(8767)。

test.rar

269.55 KB, 下载次数: 6

TA的精华主题

TA的得分主题

发表于 2017-1-23 19:15 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d = CreateObject("scripting.dictionary")
  6.   With Worksheets("sheet1")
  7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  8.     arr = .Range("a2:b" & r)
  9.     For i = 1 To UBound(arr)
  10.       d(arr(i, 1)) = d(arr(i, 1)) + 1
  11.     Next
  12.   End With
  13.   With Worksheets("sheet2")
  14.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  15.     arr = .Range("a2:b" & r)
  16.     For i = 1 To UBound(arr)
  17.       If d.exists(arr(i, 1)) Then
  18.         arr(i, 2) = d(arr(i, 1))
  19.         d.Remove (arr(i, 1))
  20.       End If
  21.     Next
  22.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
  23.     r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
  24.     If d.Count > 0 Then
  25.       .Cells(r, 1).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
  26.     End If
  27.   End With
  28. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-1-23 19:15 | 显示全部楼层
修改代码太累,另写了一个。

test.rar

277.89 KB, 下载次数: 9

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-1-23 20:50 | 显示全部楼层

谢谢,但是运行你这段代码还是有重复的项。
www.jpg

TA的精华主题

TA的得分主题

发表于 2017-1-23 20:52 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
songdg 发表于 2017-1-23 20:50
谢谢,但是运行你这段代码还是有重复的项。

不明白你的意思。

TA的精华主题

TA的得分主题

发表于 2017-1-23 21:02 | 显示全部楼层
songdg 发表于 2017-1-23 20:50
谢谢,但是运行你这段代码还是有重复的项。

我测试5894行是ousm,8767行是divo,楼主再下载褚老师的附件测试看看。

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-1-23 21:03 | 显示全部楼层
chxw68 发表于 2017-1-23 20:52
不明白你的意思。

我不知道是不是格式的原因,字典为什么会把“OUSM”当作两个key来对待(还有dwt、esgu、jhmd、sgqi、uwt、vnla等),这些项在sheet2中都有2个的。

TA的精华主题

TA的得分主题

发表于 2017-1-23 22:01 | 显示全部楼层
你现在看看。

test.rar

277.8 KB, 下载次数: 6

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-1-23 22:15 | 显示全部楼层

现在OUSM在8834行,我总感觉是A列的格式问题,但有没有发现有什么格式。

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-1-23 22:16 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
lsc900707 发表于 2017-1-23 21:02
我测试5894行是ousm,8767行是divo,楼主再下载褚老师的附件测试看看。

怎么我跟你的是不一样的,我用的是2016版的。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 14:00 , Processed in 0.044552 second(s), 15 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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