楼主
研究研究 |
Q：找出两表中的重复项？
A: 多表查找，利用双字典多数组查找
- Sheets("sheet3").Range("a1:Y65536") = ""
- Set dic = CreateObject("Scripting.Dictionary")
- Set dic1 = CreateObject("Scripting.Dictionary")
- Dim arr, arr1, arr2()
- arr = Sheets("sheet1").Range("b2:c" & Sheets("sheet1").Range("b65536").End(xlUp).Row)
- arr1 = Sheets("sheet2").Range("b2:c" & Sheets("sheet2").Range("b65536").End(xlUp).Row)
- For x = 1 To UBound(arr) '循环利用字典快速查找相同
- If Not dic.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
- dic.Add arr(x, 1) & "|" & arr(x, 2), 1
- Else
- dic(arr(x, 1) & "|" & arr(x, 2)) = 2
- End If
- Next x
- For x = 1 To UBound(arr1)
- If Not dic.Exists(arr1(x, 1) & "|" & arr1(x, 2)) Then
- dic.Add arr1(x, 1) & "|" & arr1(x, 2), 1
- Else
- dic(arr1(x, 1) & "|" & arr1(x, 2)) = 2
- End If
- Next x
- For Each x In dic.keys ‘字典自身循环查找只有一次的数据并将他删了
- If dic.Item(x) = 1 Then dic.Remove (x)
- Next x
- ReDim arr2(1 To dic.Count, 1 To 3)
- y = 1
- For x = 1 To UBound(arr) ’再次循环查找重复的地址并写入数组中
- If Not dic.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
- Else
- If Not dic1.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
- dic1.Add arr(x, 1) & "|" & arr(x, 2), y
- arr2(y, 1) = arr(x, 1)
- arr2(y, 2) = arr(x, 2)
- arr2(y, 3) = "shee1:" & x + 1 & "行"
- y = y + 1
- Else
- yy = dic1.Item(arr(x, 1) & "|" & arr(x, 2))
- arr2(yy, 3) = arr2(yy, 3) & ",shee1:" & x + 1 & "行"
- End If
- End If
- Next x
- For x = 1 To UBound(arr1)
- If Not dic.Exists(arr1(x, 1) & "|" & arr1(x, 2)) Then
- Else
- If Not dic1.Exists(arr1(x, 1) & "|" & arr1(x, 2)) Then
- dic1.Add arr1(x, 1) & "|" & arr1(x, 2), y
- arr2(y, 1) = arr1(x, 1)
- arr2(y, 2) = arr1(x, 2)
- arr2(y, 3) = "shee2:" & x + 1 & "行"
- y = y + 1
- Else
- yy = dic1.Item(arr1(x, 1) & "|" & arr1(x, 2))
- arr2(yy, 3) = arr2(yy, 3) & ",shee2:" & x + 1 & "行"
- End If
- End If
- Next x
- Sheets("sheet3").Range("a1:c" & UBound(arr2)) = arr2 ‘把结果一次性写到工作表里
 求助.rar
|