Merge cells in corresponding column based on similar values

See how it works

Option Explicit

Sub MergeData()
Dim ObjDic   As Object
Dim WkRg   As Range
Dim WSOrg  As Worksheet, WSDest  As Worksheet
Dim F  As Range
Dim Temp
Dim J  As Integer
Const OffCol As Integer = 20
    Set ObjDic = CreateObject("Scripting.Dictionary")
    Set WSOrg = Sheets("Before")
    Set WSDest = Sheets("After")
    
    Set WkRg = WSOrg.UsedRange
    Set WkRg = Intersect(WkRg, WkRg.Offset(3, 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, OffCol + J)))) Then
                        If (Len(Temp(1, J)) = 0) Then
                            Temp(1, J) = F.Offset(0, OffCol + J)
                        Else
                            Temp(1, J) = Temp(1, J) & ", " & F.Offset(0, OffCol + J)
                        End If
                    End If
                Next J
                .Item(F.Value) = Temp
            Else
                .Item(F.Value) = F.Offset(0, OffCol + 1).Resize(1, 4).Value
            End If
        Next F
        WSDest.Cells(3, 1).CurrentRegion.Offset(1, 0).Cells.ClearContents
        WSDest.Range("A4").Resize(.Count, 1) = Application.Transpose(.keys)
        WSDest.Range("W4").Resize(.Count, 4) = Application.Transpose(Application.Transpose(.items))
    End With
End Sub