VBA对比找出两表差异部分求助大佬！鲜花奉上！

约定的童话 · 发表于 2018-11-8 11:20

本帖最后由 lsc900707 于 2019-3-19 10:16 编辑

本来打算帮助别人解答的（此贴http://club.excelhome.net/thread-1444775-1-1.html），没想到遇到坎了，脑阔痛....哈哈
要求如下：通过VBA实现两表数据对比，找出差异项（判断依据：ABC某行3列完全一致为相同，有一个不一样即为不一样！），填入对比结果那里，结果已经模拟出来了，恳请大神看下！

onthetrip · 发表于 2018-11-8 11:31

看不懂模拟结果，意思是把两个表不一致的都全部罗列出来？

朱荣兴 · 发表于 2018-11-8 11:42

提示: 作者被禁止或删除内容自动屏蔽

约定的童话 · 发表于 2018-11-8 11:55

onthetrip 发表于 2018-11-8 11:31
看不懂模拟结果，意思是把两个表不一致的都全部罗列出来？

是的，找出差异项

约定的童话 · 发表于 2018-11-8 11:56

朱荣兴发表于 2018-11-8 11:42
三列对比的话用字典啊

字典还没学会，写了一段报错N多.....

朱荣兴 · 发表于 2018-11-8 12:02

提示: 作者被禁止或删除内容自动屏蔽

fyure · 发表于 2018-11-8 12:41

好像有点啰嗦，不过也是字典基本用法

约定的童话 · 发表于 2018-11-8 13:22

fyure 发表于 2018-11-8 12:41
好像有点啰嗦，不过也是字典基本用法

高手在民间啊，厉害了大师！谢谢

onthetrip · 发表于 2018-11-8 13:23

Private Sub Compare()
Dim aApply, aCheck, aResult()
Dim DicApply As Object, DicCheck As Object
Dim sCombine As String
Dim dKEY
Dim i&, j&, iCount&
aApply = Worksheets("申报表").[a1].CurrentRegion.Value
aCheck = Worksheets("登记表").[a1].CurrentRegion.Value
Set DicApply = CreateObject("scripting.dictionary")
Set DicCheck = CreateObject("scripting.dictionary")
For i = 2 To UBound(aApply)
sCombine = aApply(i, 1) & "@" & aApply(i, 2) & "@" & aApply(i, 3)
DicApply(sCombine) = i
Next
For i = 2 To UBound(aCheck)
sCombine = aCheck(i, 1) & "@" & aCheck(i, 2) & "@" & aCheck(i, 3)
DicCheck(sCombine) = i
Next
ReDim aResult(1 To UBound(aApply), 1 To 3)
For Each dKEY In DicApply
If Not DicCheck.exists(dKEY) Then
iCount = iCount + 1
For j = 1 To 3
aResult(iCount, j) = aApply(DicApply(dKEY), j)
Next
Else
DicCheck.Remove dKEY
End If
Next
[a4].Resize(iCount, 3) = aResult
ReDim aResult(1 To UBound(aCheck), 1 To 3)
iCount = 0
For Each dKEY In DicCheck
iCount = iCount + 1
For j = 1 To 3
aResult(iCount, j) = aCheck(DicCheck(dKEY), j)
Next
Next
[d4].Resize(iCount, 3) = aResult
DicApply.RemoveAll: Set DicApply = Nothing
DicCheck.RemoveAll: Set DicCheck = Nothing
End Sub

复制代码

lsc900707 · 发表于 2018-11-8 13:31

参考测试附件：

		自动登录	找回密码
密码			免费注册

[已解决] VBA对比找出两表差异部分求助大佬！鲜花奉上！

评分

评分

评分

最新热点 /1

朱荣兴朱荣兴当前离线性别保密 UID 1318548 阅读权限 0 注册时间 2011-2-2 在线时间小时最后登录 1970-1-1 积分 19282 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2018-11-8 11:42 来自手机 \| 显示全部楼层 [广告] ★ExcelHome默写助手 - 不用妈妈陪的默写神器 · Word/WPS插件 · 自定义默写单 · 自定义描红字帖★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报

朱荣兴朱荣兴当前离线性别保密 UID 1318548 阅读权限 0 注册时间 2011-2-2 在线时间小时最后登录 1970-1-1 积分 19282 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2018-11-8 12:02 来自手机 \| 显示全部楼层 [广告] ★Excel Home云课堂 - 专业的职场技能充电站★ ★Excel三大利器★ ★ 笨办法学VBA全系列★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报