Function couple(krit$, r As Range, razd$, sep As String) As String
     Dim el, s$
     couple = ""
     krit$ = Split(krit$, razd, 2)(0)
     For Each el In r.Value
         If Left(el, Len(krit)) = krit Then s = s & sep & el
     Next
     couple = Mid(s, Len(sep) + 1)
End Function

Sub www()
     Dim arr(), i As Long, it, arr1, m
     arr = Range([A1], Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).Value
     With CreateObject("Scripting.Dictionary")
         For i = LBound(arr, 1) To UBound(arr, 1)
             it = Mid(arr(i, 1), 1, 3)
             .Item(it) = .Item(it) & it & "_" & Mid(arr(i, 1), 5, 1) & ";"
         Next i
         ReDim arr(1 To .Count, 1 To 1)
         i = 1
         For Each it In .Keys
             arr1 = Split(it, "_")
             m = arr1(0) & .Item(it)
             arr(i, 1) = Mid(m, 4, Len(m) - 4)
             i = i + 1
         Next it
     End With
     [b1].Resize(i - 1, 1).Value = arr
End Sub