=Substring(ExpandListA(SubstringRev($B4,"№",1),",","-",,,,","),",",COLUMN()-4,COLUMN()-4)

Function Substring(Текст As String, Символ_разделитель As String, _
                     Начальный_Номер_фрагмента As Long, Конечный_Номер_фрагмента As Long) As String
'---------------------------------------------------------------------------------------
' URL : http://www.planetaexcel.ru/tip.php?aid=54
' Purpose : Выделяет из текста субстринг/и, ориентируясь по символам-разделителям
' Notes : Substring(текст; символ_разделитель; Начальный_Номер_фрагмента, Конечный_Номер_фрагмента), где
' текст - текст, который делим
' символ_разделитель - символ, который надо считать разделителем фрагментов
' Начальный_Номер_фрагмента - порядковый номер фрагмента, с которого нужна выборка
' Конечный_Номер_фрагмента - порядковый номер фрагмента, по который нужна выборка
'---------------------------------------------------------------------------------------
      On Error Resume Next
      Dim sArr() As String, li As Long
      sArr = Split(Application.Trim(Текст), Символ_разделитель)
      If Конечный_Номер_фрагмента > 0 Then
          Начальный_Номер_фрагмента = Начальный_Номер_фрагмента - 1
          Конечный_Номер_фрагмента = Конечный_Номер_фрагмента - 1
          For li = Начальный_Номер_фрагмента To Конечный_Номер_фрагмента
              Substring = IIf(li = Начальный_Номер_фрагмента, sArr(li), Substring & _
                     Символ_разделитель & sArr(li))
          Next li
      Else
          Substring = Split(Application.Trim(Текст), _
                            Символ_разделитель)(Начальный_Номер_фрагмента - 1)
      End If
End Function

Function ExpandListA(ByVal Src As String, _
                       Optional GrSep$ = ",", _
                       Optional InGrSep$ = "-", _
                       Optional DelChar1$ = " ", _
                       Optional DelChar2$ = " ", _
                       Optional DelChar3$ = " ", _
                       Optional outSep$ = "; ") As String
'http://www.planetaexcel.ru/forum.php?thread_id=19537
      Dim elem, aNums, j As Long, n1 As Long, n2 As Long

      Src = Replace(Src, DelChar1$, "")
      Src = Replace(Src, DelChar2$, "")
      Src = Replace(Src, DelChar3$, "")
      If Src = "" Then Exit Function
      For Each elem In Split(Src, GrSep)
          aNums = Split(elem, InGrSep)
          n1 = aNums(0)
          n2 = aNums(UBound(aNums))
          For j = n1 To n2 Step IIf(n1 < n2, 1, -1)
              ExpandListA = ExpandListA & outSep & j
          Next
      Next
      ExpandListA = Mid(ExpandListA, Len(outSep) + 1)
End Function

Function SubstringRev(Txt, Delimiter, N) As String
      Dim x As Variant
      x = Split(Txt, Delimiter)
      If N > 0 And N - 1 <= UBound(x) Then
          SubstringRev = x(UBound(x) - (N - 1))
      Else
          SubstringRev = ""
      End If
End Function