识别并提取数据的问题

笨鸟飞不高

Sub AwTest() '每组不超过2个相同的情况
    Dim i&, j%, u%, x&, r&, Sr$, arr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        arr = .Range("A1:R" & .Cells(Rows.Count, 1).End(3).Row)
        u = UBound(arr, 2)
        ReDim brr(1 To UBound(arr) * 2, 1 To u)
        For i = 1 To UBound(arr)
            Sr = arr(i, u - 1) & "|" & arr(i, u)
            d(Sr) = d(Sr) + 1
            If d(Sr) = 2 Then
                If brr(1, 1) <> "" Then r = r + 1
                r = r + 2: x = d(Sr & "|R")
                For j = 1 To u
                    brr(r - 1, j) = arr(x, j)
                    brr(r, j) = arr(i, j)
                Next
            End If
            d(Sr & "|R") = i
        Next
    End With
    If r Then
        With Sheets("Sheet3")
            .Cells.Clear
            .Range("A1").Resize(r, u) = brr
        End With
    End If
End Sub

leirongqin

wanao2008 发表于 2023-1-2 20:47
其实也可以很简单。

提供代码及视频解答，希望能够帮助到你！

你这个代码如果楼主的数据出现3个相同的，就出错啦

leirongqin

我也凑个热闹，练手代码，不受相同数据个数限制。楼上老师的代码我也看了好几家，万一楼主数据出现2个以上相同，那不就出错了吗

wanao2008

leirongqin 发表于 2023-1-3 10:29
你这个代码如果楼主的数据出现3个相同的，就出错啦

我取巧了，感觉不会出现3个相同的。感谢提醒！！