Option Explicit

Sub tt()
    Dim a, el, i&, t$, col As New Collection

    a = ActiveSheet.UsedRange.Columns(1).Resize(, 3).Value

    With CreateObject("Scripting.Dictionary")
        For Each el In Array(510101, 510102, 510103)
            .Item(el) = 0&
        Next
        For i = 2 To UBound(a)
            If Len(a(i, 2)) = 0 Then
                If Len(a(i, 1)) Then t = a(i, 1): col.Add t
            End If
            If .exists(a(i, 1)) Then
                .Item(t & "d") = a(i, 2)
                .Item(t & "c") = a(i, 3)
            End If
        Next

        ReDim a(1 To col.Count + 1, 1 To 3)
        a(1, 2) = [b1]
        a(1, 3) = [c1]
        For i = 2 To UBound(a)
            a(i, 1) = col(i - 1)
            a(i, 2) = .Item(a(i, 1) & "d")
            a(i, 3) = .Item(a(i, 1) & "c")
        Next
        [i3].Resize(UBound(a), 3).Value = a
    End With
End Sub