两列数据互相比对，求优化

·遁去的一· · 发表于 2023-6-3 01:31

本帖最后由 ·遁去的一· 于 2023-6-3 13:33 编辑

两列数据互相比对，求优化 sub 双向2（）的代码，提高速度，本机测试100万记录，100万KEY的情况下，要4分钟跑

Sub 双向2()
Dim s1, s2, jg1, jg2, jgwz1, jgwz2 '定义比对数据源的位置列变量
Dim s1arr, s2arr, jg1arr, jg2arr, jgwz1arr, jgwz2arr '定义数据源数组和各个行列的变量
Dim row1, row2 '定义总行数
Dim i, k, js, pr, sk, sk1, j '定义循环计数
Dim dic1(1 To 10) As Object
Dim t, key, Key_Is_Exist
t = Timer
Application.ScreenUpdating = False
s1 = [b1]
s2 = [b2]
jg1 = [d1]
jg2 = [d2]
jgwz1 = [f1]
jgwz2 = [f2]
row1 = Range(s1 & Rows.count).End(xlUp).Row
row2 = Range(s2 & Rows.count).End(xlUp).Row
'清理数据显示区
Range(jgwz1 & ":" & jgwz1).Clear
Range(jgwz2 & ":" & jgwz2).Clear
'For i = 2 To 1000001
' Range(s1 & i) = i
'Next
'将数据源，结果位置分别赋值
'数据源
s1arr = Range(s1 & "2:" & s1 & row1)
s2arr = Range(s2 & "2:" & s2 & row2)
'提取数据
jg1arr = Range(jg1 & "2:" & jg1 & row1)
jg2arr = Range(jg2 & "2:" & jg2 & row2)
'结果位置
jgwz1arr = Range(jgwz1 & "2:" & jgwz1 & row1)
jgwz2arr = Range(jgwz2 & "2:" & jgwz2 & row2)
'数据2在数据1中有几个相同结果
For i = 1 To 10 '生成10个字典
Set dic1(i) = CreateObject("scripting.dictionary")
Next
sk1 = 0
For i = 1 To UBound(s1arr) '循环数据1生成字典
key = s1arr(i, 1)
k = sk1 \ 100000 + 1 '计算字典号
Key_Is_Exist = False
For j = 1 To 10 '在原字典中查找是不是已有
If dic1(j).exists(key) Then
Key_Is_Exist = True
Exit For
End If
Next
If Key_Is_Exist Then
dic1(k)(s1arr(i, 1)) = dic1(k)(s1arr(i, 1)) & "," & jg1arr(i, 1) & "$" & jg1 & "$" & i + 1
Else
dic1(k).Add s1arr(i, 1), jg1arr(i, 1) & "$" & jg1 & "$" & i + 1
sk1 = sk1 + 1
End If
Next
For k = 1 To 10
'Debug.Print dic1(k).count
If dic1(k).count > 0 Then
js = dic1(k).keys
pr = dic1(k).items
sk = UBound(Split(pr(0), ",")) + 1
For i = 0 To UBound(js)
If dic1(k).exists(js(i)) Then
sk = UBound(Split(pr(i), ",")) + 1
dic1(k)(js(i)) = "(" & sk & ")" & dic1(k)(js(i))
End If
Next
End If
Next
pr = dic1(k - 1).items
'数据2在数据1中比较，提取结果到jgwz2
For i = 1 To UBound(s2arr)
key = s2arr(i, 1)
For j = 1 To 10
If dic1(j).exists(key) Then
jgwz2arr(i, 1) = dic1(j)(key)
Exit For
End If
Next
Next
Range(jgwz2 & "1").Value = s2 & "比较" & s1 & "返回" & jg1
Range(jgwz2 & "2").Resize(UBound(jgwz2arr), 1) = jgwz2arr
For k = 1 To 10
Set dic1(k) = Nothing
Next
Set jgwz2arr = Nothing
'数据1在数据2中有几个相同结果
For i = 1 To 10
Set dic1(i) = CreateObject("scripting.dictionary")
Next
sk1 = 0
For i = 1 To UBound(s2arr) '循环数据2生成字典
key = s2arr(i, 1)
k = sk1 \ 100000 + 1
Key_Is_Exist = False
For j = 1 To 10
If dic1(j).exists(key) Then
Key_Is_Exist = True
Exit For
End If
Next
If Key_Is_Exist Then
dic1(k)(s2arr(i, 1)) = dic1(k)(s2arr(i, 1)) & "," & jg2arr(i, 1) & "$" & jg2 & "$" & i + 1
Else
dic1(k).Add s2arr(i, 1), jg2arr(i, 1) & "$" & jg2 & "$" & i + 1
sk1 = sk1 + 1
End If
Next
For k = 1 To 10
' Debug.Print dic1(k).count
If dic1(k).count > 0 Then
js = dic1(k).keys
pr = dic1(k).items
sk = UBound(Split(pr(0), ",")) + 1
For i = 0 To UBound(js)
If dic1(k).exists(js(i)) Then
sk = UBound(Split(pr(i), ",")) + 1
dic1(k)(js(i)) = "(" & sk & ")" & dic1(k)(js(i))
End If
Next
End If
Next
pr = dic1(k - 1).items
'数据1在数据2中比较，提取结果到jgwz1
For i = 1 To UBound(s1arr)
key = s1arr(i, 1)
For j = 1 To 10
If dic1(j).exists(key) Then
jgwz1arr(i, 1) = dic1(j)(key)
Exit For
End If
Next
Next
Range(jgwz1 & "1").Value = s1 & "比较" & s2 & "返回" & jg2
Range(jgwz1 & "2").Resize(UBound(jgwz1arr), 1) = jgwz1arr
MsgBox "核对完成,共用时" & Timer - t & "秒" & "共核对" & row1 - 1 & "/" & row2 - 1 & "条记录"
Application.ScreenUpdating = True
For k = 1 To 10
Set dic1(k) = Nothing
Next
Set jgwz1arr = Nothing
End Sub

复制代码

完一次，追问一个问题，能否把2次互比，合成一次比对，达到相同效果，主要是互相提取指定的列数据，比重是可以一次完成的

lushang2018 · 发表于 2023-6-3 09:49

Sub CheckDataDiff()
Dim d As Object
Dim aData1, aData2, aRes, aKeys
Dim strKey As String, strMsg As String
Dim i As Long, k As Long
Dim intSame As Long, intShtA As Long, intShtB As Long
Set d = CreateObject("scripting.dictionary") '后期绑定字典
With Worksheets("表1") '表1 A列数据存入数组
aData1 = .Range("a1:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
With Worksheets("表2") '表2 A列数据存入数组
aData2 = .Range("a1:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For i = 2 To UBound(aData1) '遍历表1数据存入字典
strKey = aData1(i, 1)
d(strKey) = "表1" '将来源作为item
Next
ReDim aRes(1 To UBound(aData1) + UBound(aData2), 1 To 3) '定义结果数组大小
For i = 2 To UBound(aData2) '遍历表2数据
strKey = aData2(i, 1)
If d.exists(strKey) Then '如果存在关键字……
If d(strKey) = "表1" Then '如果该关键字属于表1，这层判断是为了避免表2存在重复值
intSame = intSame + 1 '累加相同个数
aRes(intSame, 1) = strKey '存入结果数组第1列
d(strKey) = "相同" '将关键字对应的item修改为相同
End If
Else '如果字典不存在该关键字，说明是表2独有
intShtB = intShtB + 1 '累加B表独有个数
aRes(intShtB, 3) = strKey '存入结果数组第3列
d(strKey) = "表2" '存入字典，item为来源表2
End If
Next
aKeys = d.keys '字典的keys集合
For i = 0 To UBound(aKeys) '遍历字典剔除tiem相同的即为A表独有值
strKey = aKeys(i)
If d(strKey) = "表1" Then
intShtA = intShtA + 1 '累加A表独有个数
aRes(intShtA, 2) = strKey '存入结果数组第2列
End If
Next
If k < intSame Then k = intSame
If k < intShtA Then k = intShtA
If k < intShtB Then k = intShtB
Worksheets("结果").Select
Range("a:e").ClearContents
Range("a1").Resize(UBound(aData1), 1) = aData1 'A列放表1数据
Range("b1").Resize(UBound(aData2), 1) = aData2 'B列放表2数据
Range("a1:e1") = Array("A表数据", "B表数据", "相同项", "A表独有", "B表独有")
Range("c2").Resize(k, UBound(aRes, 2)) = aRes '结果数组数据
strMsg = "两表相同项：" & intSame & vbCrLf _
& "A表独有项：" & intShtA & vbCrLf _
& "B表独有项：" & intShtB
MsgBox strMsg, , "公众号Excel星球"
Set d = Nothing
End Sub

复制代码

·遁去的一· · 发表于 2023-6-3 11:22

是太菜还是太难啊，没人理吗？

·遁去的一· · 发表于 2023-6-3 11:52

自己顶一下大大看看

·遁去的一· · 发表于 2023-6-3 12:50

经坛友指点，发现82行 161行 dic1(k)(s1arr(i, 1)) = dic1(k)(s1arr(i, 1)) & "," & jg1arr(i, 1) & "$" & jg1 & "$" & i + 1应改为： dic1(j)(s1arr(i, 1)) = dic1(j)(s1arr(i, 1)) & "," & jg1arr(i, 1) & "$" & jg1 & "$" & i + 1

·遁去的一· · 发表于 2023-6-3 18:31

lushang2018 发表于 2023-6-3 09:49

代码很牛，但是有几个我的要求没达到，一是两列数据值相同时，提取指定的列数据给对方，二是没有对方的地址这项，重复的项要累加起来并计算重复的次数，每个返回的值都要是指定列的value+address这样的形式。经测100万行数据用时4分多钟，谢谢老大

·遁去的一· · 发表于 2023-6-4 02:48

呼叫版主大人来帮忙解决

·遁去的一· · 发表于 2023-6-4 16:15

呼叫版主大人来帮忙解决,是太难还是太菜啊，没人理的

zjzyj · 发表于 2023-6-4 20:00

没人跟贴是因为你的附件中没有数据，如果附件有数据，而且需求清晰，相信会有很多人跟贴的。你只是放了一堆代码上来，那是很少有人愿意看的，因为读别人写的代码是一件比较痛苦的事情

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

[求助] 两列数据互相比对，求优化