مقارنة قيم و تطابقها في الصف

Sub Test()

    Dim a, b, v, rng As Range, i As Long, j As Long

    

    a = Range("D1:F" & Cells(Rows.Count, 4).End(xlUp).Row).Value

    ReDim b(1 To UBound(a, 1) + 1000, 1 To UBound(a, 2))

    

    For i = LBound(a) To UBound(a)

        v = Application.Match(a(i, 1), Columns(1), 0)

        If Not IsError(v) Then

            For j = LBound(a, 2) To UBound(a, 2)

                b(v, j) = a(i, j)

            Next j

            If rng Is Nothing Then Set rng = Cells(v, 7).Resize(, 3) Else Set rng = Union(rng, Cells(v, 7).Resize(, 3))

        End If

    Next i

    

    Range("G1").Resize(UBound(b, 1), UBound(b, 2)).Value = b

    If Not rng Is Nothing Then rng.Interior.ColorIndex = 27

End Sub