求助

gwjkkkkk

Sub TEST6()
    Dim arr, brr, i&, j&, R&, dic As Object, iPosCol&
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    With Range("A1").CurrentRegion.Resize(, 2)
        arr = Intersect(.Offset(), .Offset(1))
    End With
    ReDim brr(1 To UBound(arr), 1 To 2)
    For i = 1 To 2
        dic.RemoveAll: R = 0
        iPosCol = IIf(i = 1, 2, 1)
        For j = 1 To UBound(arr)
          dic(Val(arr(j, iPosCol))) = ""
        Next j
        For j = 1 To UBound(arr)
           If Not dic.exists(Val(arr(j, i))) Then
              R = R + 1
              brr(R, i) = arr(j, i)
           End If
        Next j
    Next i
    [E2].Resize(UBound(brr), 2) = brr
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请楼主参考附件。。。

cowrn

用字典解了一下，看看是否合适

Sub 字典法()

    Dim dicA As Object, dicB As Object
    Dim arr
    Dim i&
   
    arr = Cells(1, 1).CurrentRegion
    Set dicA = CreateObject("scripting.dictionary")
    Set dicB = CreateObject("scripting.dictionary")
   
    For i = 2 To UBound(arr)
        dicA(CStr(arr(i, 1))) = ""
        dicB(CStr(arr(i, 2))) = ""
    Next
   
    For i = 2 To UBound(arr)
        If dicA.exists(CStr(arr(i, 2))) Then dicA.Remove CStr(arr(i, 2))
        If dicB.exists(CStr(arr(i, 1))) Then dicB.Remove CStr(arr(i, 1))
    Next
   
    [H2].Resize(dicA.Count, 1) = WorksheetFunction.Transpose(dicA.keys)
    [I2].Resize(dicB.Count, 1) = WorksheetFunction.Transpose(dicB.keys)
   
    Set dicA = Nothing
    Set dicB = Nothing
    Erase arr
   
End Sub

boy8199

你太懒了, 我也懒得看.