提取两列重复取至另一列（源数据超过65536行）

pkmz

各位大神好，本小弟弟使用的代码是：Sub 按钮1_Click()Sheets("sheet1").Select
Set mydic = CreateObject("Scripting.Dictionary")
myarr1 = Range([x2], [x65536].End(xlUp))
myarr2 = Range([y2], [y65536].End(xlUp))
For i = 1 To UBound(myarr1) '将键值赋值为0
mydic(myarr1(i, 1)) = 0
Next
For j = 1 To UBound(myarr2) '如果数组2在字典中存在相应的键，那么将键值更改为1
If mydic.exists(myarr2(j, 1)) Then mydic(myarr2(j, 1)) = 1
Next '对于字典中的每个键进行判断，如果相应的键值为0，也就是说在数组2中不存在，那么移除
For Each d In mydic.keys
If mydic(d) = 0 Then mydic.Remove (d)
Next '将字典数据回填到工作表
[z:z].ClearContents
Range("z1") = "铺货重复的值"
Range("z2").Resize(mydic.Count, 1) = WorksheetFunction.Transpose(mydic.keys)
End Sub
当行数超过65536行就运行不下去了，提供类型不匹配，请大神指教；

pkmz

不是同行比较，两列中不同行重复也算重复；