设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 关于字典查询求助
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2478|回复: 8

[已解决]关于字典查询求助

[复制链接]
发表于 2013-10-31 10:31 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
求助啊·········
最佳答案
月排行榜 / 总排行榜
liuguansky
2013-10-31 15:55
  1. Sub df()
  2.     Dim D(1) As New Dictionary, Arr(1), K&, U&
  3.     Dim Ar(1 To 1000, 1 To 3), ArErr$(), strErr$
  4.     strErr = "此记录姓名可能录入有误,请核实!"
  5.     Arr(0) = Sheet1.Range("A1").CurrentRegion.Value
  6.     Arr(1) = Sheet2.Range("A1").CurrentRegion.Value
  7.     ReDim ArErr(1 To UBound(Arr(1)), 1 To 1)
  8.     For i = 2 To UBound(Arr(0))
  9.         D(0).Add Arr(0)(i, 2), i
  10.     Next i
  11.     For i = 2 To UBound(Arr(1))
  12.         If D(0).Exists(Arr(1)(i, 2)) Then
  13.             If Arr(1)(i, 1) <> Arr(0)(D(0)(Arr(1)(i, 2)), 1) Then
  14.                 ArErr(i, 1) = strErr
  15.             End If
  16.             D(1)(Arr(1)(i, 2)) = D(1)(Arr(1)(i, 2)) + Arr(1)(i, 3)
  17.         End If
  18.     Next i
  19.     Arr(1) = D(0).Keys
  20.     For i = 0 To UBound(Arr(1))
  21.         K = D(0)(Arr(1)(i))
  22.         If D(1).Exists(Arr(1)(i)) Then
  23.             If Arr(0)(K, 3) <> D(1)(Arr(1)(i)) Then
  24.                 U = U + 1
  25.                 Ar(U, 1) = Arr(0)(K, 1)
  26.                 Ar(U, 2) = Arr(0)(K, 2)
  27.                 Ar(U, 3) = Arr(0)(K, 3) - D(1)(Arr(1)(i))
  28.             End If
  29.         Else
  30.             U = U + 1
  31.             Ar(U, 1) = Arr(0)(K, 1)
  32.             Ar(U, 2) = Arr(0)(K, 2)
  33.             Ar(U, 3) = Arr(0)(K, 3)
  34.         End If
  35.     Next i
  36.     Sheet2.[d1].Resize(UBound(ArErr)) = ArErr
  37.     Sheet3.[a2].Resize(U, 3) = Ar
  38. End Sub
复制代码
看下是否为附件效果?
求解.zip (12.2 KB, 下载次数: 12)

求解.rar

7.66 KB, 下载次数: 8
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2013-10-31 11:08 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
提示的时候，放在第一张表还是第二张表中？
回复

使用道具 举报

发表于 2013-10-31 11:20 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub df()
  2.     Dim D As New Dictionary, Arr(1), K&, U&
  3.     Dim Ar(1 To 1000, 1 To 3), S$, Derr As New Dictionary
  4.     Arr(0) = Sheet1.Range("A1").CurrentRegion.Value
  5.     Arr(1) = Sheet2.Range("A1").CurrentRegion.Value
  6.     For i = 2 To UBound(Arr(0))
  7.         D.Add Arr(0)(i, 2), i
  8.     Next i
  9.     For i = 2 To UBound(Arr(1))
  10.         If D.Exists(Arr(1)(i, 2)) Then
  11.             K = D(Arr(1)(i, 2))
  12.             If Arr(0)(K, 1) = Arr(1)(i, 1) Then
  13.                 If Arr(0)(K, 3) <> Arr(1)(i, 3) Then
  14.                     U = U + 1
  15.                     Ar(U, 1) = Arr(1)(i, 1)
  16.                     Ar(U, 2) = Arr(1)(i, 2)
  17.                     Ar(U, 3) = Arr(0)(K, 3) - Arr(1)(i, 3)
  18.                 End If
  19.             Else
  20.                 Derr.Add Arr(1)(i, 2), Arr(1)(i, 2) & "在第" & i & "行"
  21.             End If
  22.         End If
  23.     Next i
  24.     Sheet3.[a2].Resize(U, 3) = Ar
  25.     If Derr.Count > 0 Then
  26.         MsgBox "身份证" & Join(Derr.Items, vbCrLf) & _
  27.                     "存在名字输入有误!,请核实"
  28.     End If
  29.     Set D = Nothing: Set Derr = Nothing
  30. End Sub
复制代码
求解.zip (12.22 KB, 下载次数: 10)

评分

参与人数 1 +18 收起 理由
CheryBTL + 18 学习 字典+数组

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-10-31 12:45 | 显示全部楼层
liuguansky 发表于 2013-10-31 11:20

提示的时候放在第二张或第一张都可以的····
回复

使用道具 举报

 楼主| 发表于 2013-10-31 12:50 | 显示全部楼层
CheryBTL 发表于 2013-10-31 11:08
提示的时候，放在第一张表还是第二张表中？

第一张第二张都可以的，运行应该是一个张三啊！！！最后的余额·····能行吗？？？
QQ图片20121103124953.jpg
回复

使用道具 举报

 楼主| 发表于 2013-10-31 14:30 | 显示全部楼层
liuguansky 发表于 2013-10-31 11:20

亲，修改身份证后张三的余额应该是3000-200-400=2400，还有就是李四在二表中没有，就直接移到第三张表·· 是这样的·· 能行吗？？？？？感谢·····
回复

使用道具 举报

发表于 2013-10-31 15:55 | 显示全部楼层    本楼为最佳答案   
  1. Sub df()
  2.     Dim D(1) As New Dictionary, Arr(1), K&, U&
  3.     Dim Ar(1 To 1000, 1 To 3), ArErr$(), strErr$
  4.     strErr = "此记录姓名可能录入有误,请核实!"
  5.     Arr(0) = Sheet1.Range("A1").CurrentRegion.Value
  6.     Arr(1) = Sheet2.Range("A1").CurrentRegion.Value
  7.     ReDim ArErr(1 To UBound(Arr(1)), 1 To 1)
  8.     For i = 2 To UBound(Arr(0))
  9.         D(0).Add Arr(0)(i, 2), i
  10.     Next i
  11.     For i = 2 To UBound(Arr(1))
  12.         If D(0).Exists(Arr(1)(i, 2)) Then
  13.             If Arr(1)(i, 1) <> Arr(0)(D(0)(Arr(1)(i, 2)), 1) Then
  14.                 ArErr(i, 1) = strErr
  15.             End If
  16.             D(1)(Arr(1)(i, 2)) = D(1)(Arr(1)(i, 2)) + Arr(1)(i, 3)
  17.         End If
  18.     Next i
  19.     Arr(1) = D(0).Keys
  20.     For i = 0 To UBound(Arr(1))
  21.         K = D(0)(Arr(1)(i))
  22.         If D(1).Exists(Arr(1)(i)) Then
  23.             If Arr(0)(K, 3) <> D(1)(Arr(1)(i)) Then
  24.                 U = U + 1
  25.                 Ar(U, 1) = Arr(0)(K, 1)
  26.                 Ar(U, 2) = Arr(0)(K, 2)
  27.                 Ar(U, 3) = Arr(0)(K, 3) - D(1)(Arr(1)(i))
  28.             End If
  29.         Else
  30.             U = U + 1
  31.             Ar(U, 1) = Arr(0)(K, 1)
  32.             Ar(U, 2) = Arr(0)(K, 2)
  33.             Ar(U, 3) = Arr(0)(K, 3)
  34.         End If
  35.     Next i
  36.     Sheet2.[d1].Resize(UBound(ArErr)) = ArErr
  37.     Sheet3.[a2].Resize(U, 3) = Ar
  38. End Sub
复制代码
看下是否为附件效果?
求解.zip (12.2 KB, 下载次数: 12)
回复

使用道具 举报

 楼主| 发表于 2013-10-31 16:08 | 显示全部楼层
liuguansky 发表于 2013-10-31 15:55
看下是否为附件效果?

感谢了·1···  就是这个····
回复

使用道具 举报

 楼主| 发表于 2013-11-1 14:58 | 显示全部楼层
liuguansky 发表于 2013-10-31 15:55
看下是否为附件效果?

亲，您能给代码后面添加注释吗？我还有很多条件要添加的，你写的有些代码我不理解那个意思·····
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-29 07:59 , Processed in 0.690521 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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