match or compare 2 columns to distinguish duplicate data

I have spent so much time trying to resolve this, and help is much appreciated.

I have attached a spreadsheet where I have some same and some different data in column a and columnb. I need to sort the data so I can see the same value on the same row.

E.G. I have the below extract:

Party Number Party Number 2
500012281 500021685
500016910 500009119
500021685 500012281

I need it to show as the below to identify the same data in each column

Party Number Party Number 2
500012281 500012281
500016910
500021685 500021685

Here I can see that column2 has two entries that are duplicated in column1, and one entry that has duplicate. Is there a way of soriting and arranging this data?

Public Sub SortData()
    Dim w As Worksheet
    Dim rng As Range
    Dim er As Long
    
    On Error GoTo Err_Exit
    
    Set w = ActiveSheet
    
    w.Columns(1).Sort w.Cells(1, 1), xlAscending, Header:=xlGuess
    w.Columns(2).Insert
    er = w.Cells(w.Rows.Count, 1).End(xlUp).Row
    For r = 2 To er
        Set rng = w.Columns(3).Find(w.Cells(r, 1).Value)
        If Not rng Is Nothing Then
            rng.Copy
            w.Cells(r, 2).PasteSpecial xlPasteAll
            rng.Value = ""
            Set rng = Nothing
        End If
    Next r
    
    w.Columns(3).Sort w.Cells(1, 3), xlAscending, Header:=xlGuess
    
    
    GoTo Std_Exit
    
Err_Exit:
    m = MsgBox(Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "Error")
    GoTo Std_Exit

Std_Exit:
    Set w = Nothing
    
End Sub

This will sort the first column of data (probably not needed), then insert a column to the right. It will then run through each row of column 1 and look for the value in column 3, if found copy the value from col 3 into col 2 and remove from col 3. Repeats for all of column 1, meaning all values left in column 3 are ones without a duplicate in column 1. It then sorts these values into a condensed list.

Any good?

as an option

Sub ertert()
Dim x, y(), i&, j&, k&
x = Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To 2): j = 1
y(1, 1) = "Party Number 2": y(1, 2) = "(Party Number 2) - (Party Number)"

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(x)
        If Len(x(i, 1)) Then .Item(x(i, 1)) = i
    Next i

    For i = 2 To UBound(x)
        If .Exists(x(i, 2)) Then
            y(.Item(x(i, 2)), 1) = x(i, 2)
        Else
            j = j + 1: y(j, 2) = x(i, 2)
        End If
    Next i
End With

[f1:g1].Resize(i - 1).Value = y
End Sub