两列的料号相同，但A列比B列多料，，如何查出A列比B列多哪些料，求VBA代码，我用字典

360583279

两列的料号用字典对比是相同的，但A列比B列多料，A列有重复料，B列没有重复料，如何查出A列比B列多哪些料，求VBA代码，我用字典 没有达到要求 USB13RAM35015901	難道咱出了難題，沒有人能回答出來？ USB13RAM35015901
USB23RAM35015901	USB23RAM35015901
J23RAM38004500	J23RAM38004500
PCB板3RAM63041301	PCB板3RAM63041301
C13RAMC2107078	C13RAMC2107078
C23RAMC2107078	C23RAMC2107078
LED53RAME0003400	LED53RAME0003400
LED23RAME0003500	LED23RAME0003500
LED13RAME0003600	LED13RAME0003600
LED33RAME0003600	LED33RAME0003600
LED43RAME0003600	LED43RAME0003600
LED1燈座3RAMPS010200	LED1燈座3RAMPS010200
LED2燈座3RAMPS010200	LED2燈座3RAMPS010200
LED3燈座3RAMPS010200	LED3燈座3RAMPS010200
LED4燈座3RAMPS010200	LED4燈座3RAMPS010200
LED5燈座3RAMPS010200	LED5燈座3RAMPS010200
LED燈座3RAMPS010200	LED燈座3RAMPS010200
S13RAMS0003700	S13RAMS0003700
S23RAMS0003700	S23RAMS0003700
LED53RAME0003400
LED23RAME0003500
LED13RAME0003600
LED33RAME0003600
LED43RAME0003600

360583279

我用了个蠢办法，先用字典比较两列，如果全部存在，然后用下面程序查检有无重复
Public Sub 查找SOP多料情况() 'I列即为A列，F列即为B列
[R:R].Clear
Dim DRR(), I%, CC%, K%, LIAO$, J%
CC = Range("i65536").End(xlUp).Row
ReDim DRR(1 To CC)
For I = 1 To CC
    LIAO = Range("F" & I)
    On Error Resume Next
    J = Range("I:I").Find(LIAO, , , xlWhole).Row
    If Application.CountIf(Range(Cells(J, "I"), Cells(CC, "I")), Range("F" & I)) > 1 Then
        K = K + 1
        DRR(K) = Range("I" & J)
    End If
Next I
ReDim Preserve DRR(1 To K)
Range("R1").Resize(UBound(DRR)) = Application.Transpose(DRR)

360583279

Sub 异同项() '佛山小老鼠回答了我的问题，但没有解决A列重复项提取的问题
    Dim DicA, DicB, DicC, arrA, arrB, x&, y&, k&, a&, b&, arr1, arr2
    Dim AyesBno(1 To 100, 1 To 1), AyesByes(1 To 100, 1 To 1), AnoByes(1 To 100, 1 To 1)
    Dim i&, ii&, iii&, j&
    Set DicA = CreateObject("Scripting.Dictionary")
    Set DicB = CreateObject("Scripting.Dictionary")
    Set DicC = CreateObject("Scripting.Dictionary")
    a = Cells(Rows.Count, 1).End(xlUp).Row
    b = Cells(Rows.Count, 2).End(xlUp).Row
    arrA = Range("A1:A" & a)
    arrB = Range("B1:B" & b)
    For x = 1 To UBound(arrA)
        If Not DicA.exists(arrA(x, 1)) Then
            DicA(arrA(x, 1)) = ""
            DicC(arrA(x, 1)) = ""
        End If
    Next x
    For y = 1 To UBound(arrB)
        If Not DicB.exists(arrB(y, 1)) Then
            DicB(arrB(y, 1)) = ""
            DicC(arrB(y, 1)) = "" ?
        End If
    Next y
    arr1 = DicA.keys 'arr1,arr2   
arr2 = DicB.keys
       '================================================
    On Error Resume Next
    For j = 0 To DicA.Count - 1
        DicB.Add arr1(j), ""
        If ERR.Number = 0 Then
                      i = i + 1
            AyesBno(i, 1) = arr1(j)
        Else
                  ii = ii + 1
            AyesByes(ii, 1) = arr1(j)
        End If
        ERR = 0
    Next j
    '==========================================
    For k = 0 To DicB.Count - 1
        DicA.Add arr2(k), ""
        If ERR.Number = 0 Then
            iii = iii + 1
            AnoByes(iii, 1) = arr2(k)
        End If
        ERR = 0
    Next k
    [D1] = "A?B?斑??"
    [D2].Resize(DicC.Count, 1) = Application.Transpose(DicC.keys)
    [E1] = "A?B???"
    [E2].Resize(ii, 1) = AyesByes
    [f1] = "A?ΤB?⊿Τ?"
    [F2].Resize(i, 1) = AyesBno
    [G1] = "A?⊿ΤB?Τ"
    [G2].Resize(iii, 1) = AnoByes
    Range("D1:G1").EntireColumn.AutoFit
End Sub