Option Explicit

Sub jjj()
    Dim arrEt(), arrIn(), arrOut()
    Dim i As Long, j As Long, l_Et As Long, l_In As Long, lCnt As Long
    
    With ActiveSheet
        arrEt = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value: l_Et = UBound(arrEt, 1)
        arrIn = .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value: l_In = UBound(arrIn, 1)
        ReDim arrOut(1 To .Rows.Count, 1 To 1)
        
        With CreateObject("Scripting.Dictionary")
            For i = 1 To l_In
                If .Exists(arrIn(i, 1)) Then
                    .Item(arrIn(i, 1)) = .Item(arrIn(i, 1)) + 1
                Else
                    .Add arrIn(i, 1), 1
                End If
            Next i
            
            For i = 1 To l_Et
                If .Exists(arrEt(i, 1)) Then
                    arrOut(i, 1) = arrEt(i, 1)
                    If .Item(arrEt(i, 1)) = 1 Then
                        .Remove arrEt(i, 1)
                    Else
                        .Item(arrEt(i, 1)) = .Item(arrEt(i, 1)) - 1
                    End If
                End If
            Next i
            
            lCnt = l_Et
            For i = 0 To .Count - 1
                For j = 1 To .Items()(i)
                    lCnt = lCnt + 1
                    arrOut(lCnt, 1) = .Keys()(i)
                Next j
            Next i
        End With ' CreateObject("Scripting.Dictionary")
        .Range("E1:E" & lCnt).Value = arrOut
    End With ' ActiveSheet
End Sub