Sub ConcatUnique()
Dim Rng As Range
Dim Dic As Object
Dim Cl As Range
Set Dic = CreateObject("scripting.dictionary")
For Each Rng In Range("B:B").SpecialCells(xlBlanks).Areas
For Each Cl In Rng.Offset(-1, -1).Resize(Rng.Count + 1)
If Not Dic.exists(Cl.Value) Then Dic.Add Cl.Value, Nothing
Next Cl
Rng.Offset(-1, -1).Resize(1).Value = Join(Dic.keys, ",")
Dic.removeall
Next Rng
Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
End Sub