|
发表于 2014-7-22 17:16
|
显示全部楼层
本楼为最佳答案
试试看- Sub test()
- Dim dic1, dic2, ar, i&, j&, st$, br(), n&, t
- Set dic1 = CreateObject("scripting.dictionary")
- Set dic2 = CreateObject("scripting.dictionary")
- ar = Sheets("1").Range("a1").CurrentRegion
- For i = 3 To UBound(ar)
- For j = 6 To UBound(ar, 2)
- If ar(i, j) > 0 Then
- st = ar(i, 2) & "|" & Val(ar(2, j))
- dic1(st) = ar(i, j)
- End If
- Next
- Next
- ar = Sheets("2").Range("a1").CurrentRegion
- For i = 2 To UBound(ar)
- If ar(i, 11) > 0 Then
- st = ar(i, 5) & "|" & Val(ar(i, 10))
- dic2(st) = ar(i, 11) & "|" & ar(i, 6)
- End If
- Next
- ReDim br(1 To dic1.Count + dic2.Count, 1 To 4)
- For Each t In dic2.keys '遍历2表,如表1不存在该项或存在但价格不等就加入表3
- If Not dic1.exists(t) Then
- n = n + 1
- br(n, 1) = Split(t, "|")(0)
- br(n, 3) = Split(t, "|")(1)
- br(n, 2) = Split(dic2(t), "|")(1)
- br(n, 4) = "表2有表1无"
- Else
- If dic1(t) <> Val(dic2(t)) Then
- n = n + 1
- br(n, 1) = Split(t, "|")(0)
- br(n, 3) = Split(t, "|")(1)
- br(n, 2) = Split(dic2(t), "|")(1)
- br(n, 4) = "价格不等"
- End If
- dic1.Remove (t) '两表都存在的项目移除以免结果重复
- End If
- Next
- For Each t In dic1.keys '表1中项目在表2不存在的
- n = n + 1
- br(n, 1) = Split(t, "|")(0)
- br(n, 3) = Split(t, "|")(1)
- br(n, 4) = "表1有表2无"
- Next
- If n > 0 Then
- With Sheets("3")
- .Range("a2:d" & Rows.Count).ClearContents
- .Range("a2").Resize(n, 4) = br
- End With
- End If
- End Sub
复制代码 |
|