OzGrid

'solution similar to, http://www.ozgrid.com/forum/showthread.php?t=205473
Sub Main()
  Dim rS As Range, rT As Range, c As Range, f As Range
  Dim f1 As Range, f2 As Range
  'Add Tools > References > Microsoft Scripting Runtime
  Dim d As New Dictionary, e
  Dim a1(), a2(), b1(), b2(), u(), i As Integer, s As String
  
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  'On Error GoTo EndSub
  
  'Set column L and M ranges and working arrays.
  Set rS = Range("L2", Range("L2").End(xlDown))
  a1 = WorksheetFunction.Transpose(rS.Value)
  a2 = a1
  Set rT = Range("M2", Range("M2").End(xlDown))
  b1 = WorksheetFunction.Transpose(rT.Value)
  b2 = b1

  'Remove # suffix from column L.
  For i = 1 To rS.Cells.Count
   a2(i) = Split(a2(i), "#")(0) 'Remove # suffix
  Next i
  'Write back column L values without # suffixes.
  rS.Value = WorksheetFunction.Transpose(a2)
  
  'Make a2 values unique.
  u() = UniqueArrayByDict(a2())
  
  'Store unique values into dictionary.
  For i = 1 To UBound(u)
    d.Add u(i), Nothing
  Next i
  
  'Iterate column L values without suffixes.
  For i = 1 To UBound(a2)
    s = ""
    Set f1 = FindAll(rS, a2(i), xlValues, xlWhole, xlByRows, False)
    b2(i) = b1(i)
    If f1.Cells.Count > 1 And d.Exists(a2(i)) Then
      For Each c In f1.Offset(, 1)
        s = s & c.Value & "; "
      Next c
      s = Left(s, Len(s) - 2)
      b2(i) = s
    End If
    If d.Exists(a2(i)) Then d.Remove (a2(i))
  Next i
  
  'Write back column L values with # suffixes.
  rS.Value = WorksheetFunction.Transpose(a1)
  
  'Write back column M values with first unique group join.
  rT.Value = WorksheetFunction.Transpose(b2)
  
EndSub:
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub


 'https://msdn.microsoft.com/en-us/library/system.collections.arraylist(v=vs.110).aspx
Function advArrayListSort(sn As Variant, Optional tfAscending1 As Boolean = True, _
    Optional tfAscending2 As Boolean = True, _
    Optional tfNumbersFirst As Boolean = True) As Variant
     
    Dim i As Long, c1 As Object, c2 As Object
    Dim a1() As Variant, a2() As Variant, a() As Variant
     
    Set c1 = CreateObject("System.Collections.ArrayList")
    Set c2 = CreateObject("System.Collections.ArrayList")
     
    For i = LBound(sn) To UBound(sn)
        If IsNumeric(sn(i)) = True Then
            c1.Add sn(i)
        Else
            c2.Add sn(i)
        End If
    Next i
     
    c1.Sort 'Sort ascendending
    c2.Sort 'Sort ascending
     
    If tfAscending1 = False Then c1.Reverse 'Sort and then Reverse to sort descending
    If tfAscending2 = False Then c2.Reverse 'Sort and then Reverse to sort descending
     
    a1() = c1.Toarray()
    a2() = c2.Toarray()
     
    If tfNumbersFirst = True Then
        a() = a1()
        For i = 1 To c2.Count
            ReDim Preserve a(UBound(a) + 1)
            a(UBound(a)) = a2(i - 1)
        Next i
    Else
        a() = a2()
        For i = 1 To c1.Count
            ReDim Preserve a(UBound(a) + 1)
            a(UBound(a)) = a1(i - 1)
        Next i
    End If
     
    advArrayListSort = a()
End Function

' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
  'Dim dic As Object 'Late Binding method - Requires no Reference
  'Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  Dim dic As Dictionary     'Early Binding method
  Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function