对1列数据重复性比较，并提取重复数据

雪之花

如图，对A2:B区域的数据，按A列数据进行比较：若有A列单元格有重复的，将重复的数据提取到C2:D

nie414006

模拟结果不对吧

ykcbf1100

重复值。。。
代码简化一下。

雪之花

nie414006 发表于 2022-11-30 12:44
模拟结果不对吧

需要的结果

Hontyu

...............

gwjkkkkk

Sub TEST5()
    Dim arr, brr, i&, R&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion.Resize(, 2)
    ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2))
    For i = 2 To UBound(arr): dic(arr(i, 1)) = dic(arr(i, 1)) + 1: Next
    For i = 2 To UBound(arr)
       If dic(arr(i, 1)) > 1 Then
           R = R + 1
           brr(R, 1) = arr(i, 1): brr(R, 2) = arr(i, 2)
       End If
    Next
    Set dic = Nothing
    [C2].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

gwjkkkkk

参与一下。。。

破例

Sub aa()

    Application.Calculation = xlCalculationManual

    r = Cells(Rows.Count, 1).End(xlUp).Row
   
    Range("a2:b" & r).Sort Range("a1")
   
    jc = 1
    For i = 2 To r
        
        If Cells(i, 1) = Cells(i - 1, 1) Then
            If cf = 0 Then
                jc = jc + 1
                Cells(jc, 3) = Cells(i - 1, 1)
                Cells(jc, 4) = Cells(i - 1, 2)
            End If
            jc = jc + 1
            cf = cf + 1
            Cells(jc, 3) = Cells(i, 1)
            Cells(jc, 4) = Cells(i, 2)
        Else
            cf = 0
        End If
   
    Next i
   
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "完成"
   
End Sub

grf1973

利用原数组即可。

grf1973

不用字典也行。