Merge cells in corresponding column based on similar values

Try

Option Explicit

Sub MergeData()
Dim ObjDic   As Object
Dim WkRg   As Range
Dim F  As Range
Dim Temp
Dim J  As Integer
    Set ObjDic = CreateObject("Scripting.Dictionary")
    Set WkRg = Sheets("Before").Cells(3, 1).CurrentRegion
    Set WkRg = Intersect(WkRg, WkRg.Offset(1, 0))
    
    With ObjDic
        For Each F In WkRg.Columns(1).Cells
            If (.exists(F.Value)) Then
                Temp = .Item(F.Value)
                For J = 1 To UBound(Temp, 2)
                    If (Not (IsEmpty(F.Offset(0, J)))) Then
                        If (Len(Temp(1, J)) = 0) Then
                            Temp(1, J) = F.Offset(0, J)
                        Else
                            Temp(1, J) = Temp(1, J) & ", " & F.Offset(0, J)
                        End If
                    End If
                Next J
                .Item(F.Value) = Temp
            Else
                .Item(F.Value) = F.Offset(0, 1).Resize(1, 4).Value
            End If
        Next F
        Sheets("After").Cells(3, 1).CurrentRegion.Offset(1, 0).Cells.ClearContents
        Sheets("After").Range("A4").Resize(.Count, 1) = Application.Transpose(.keys)
        Sheets("After").Range("B4").Resize(.Count, 4) = Application.Transpose(Application.Transpose(.items))
    End With
End Sub