Compare columns and insert values in correct place

try

Sub ertert()
Dim x, i&
With Sheets("Sheet3")
    x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x): .Item(x(i, 2)) = x(i, 1): Next i
    With Sheets("CADIM")
        x = .Range("B1:C" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
    End With
    For i = 1 To UBound(x): .Item(x(i, 2)) = x(i, 1): Next i
    Sheets("Sheet3").Range("A1:B1").Resize(.Count).Value = WorksheetFunction.Transpose(Array(.items, .keys))
End With
With Sheets("Sheet3")
    With .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .Sort Key1:=.Cells(1, 2), Order1:=xlDescending
    End With
End With
End Sub