按条件提取两表中二级明细不重复记录到表三

代码如下：

Sub symx()
Dim Krr, i&, d, Lrr, t, x$, y$, r%, Krr1()
Set d = CreateObject("Scripting.Dictionary")
Sheet3.Activate
[d4:d500].ClearContents
Krr = Sheet5.[a1].CurrentRegion
For i = 2 To UBound(Krr)
    x = Krr(i, 6): y = Krr(i, 7)
    If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    d(x)(y) = y
Next
Lrr = Sheet3.[a1].CurrentRegion
For i = 4 To UBound(Lrr)
    If Lrr(i, 2) = "" Then
        r = r + 1
        ReDim Preserve Krr1(1 To r)
        Krr1(r) = i
    End If
Next
For i = 1 To r
    If d.exists(Lrr(Krr1(i), 3)) Then
        t = d(Lrr(Krr1(i), 3)).keys
        If UBound(t) > 0 Then
            Cells(Krr1(i) + 1, 4).Resize(UBound(t) + 1) = Application.Transpose(t)
        Else
            Cells(Krr1(i) + 1, 4) = t(0)
        End If
    End If
Next
End Sub