Как собрать в одну ячейку значения из столбца ч группировкой по номерам?

Sub Сбор_хран()
Dim wb As Workbook, LRow As Long, Z As Range, ТМ As String, aCell As Range, s$
    Set wb = ThisWorkbook
For Each Z In wb.Sheets(1).Range("C19:C" & wb.Sheets(1).Cells(Rows.Count, 3).End(xlUp).Row)
For Each aCell In wb.Sheets(2).Range("D2:D" & wb.Sheets(2).Cells(Rows.Count, 4).End(xlUp).Row)
    If Left(aCell, 2) = "ОS" Then ТМ = Left(aCell, 7) Else If Left(aCell, 2) = "ОN" Then ТМ = Left(aCell, 8)
    If Z = ТМ And aCell <> aCell.Offset(1, 0) Then
        If Left(Right(aCell, 8), 1) = "5" And Left(Right(aCell, 8), 5) = Left(Right(aCell.Offset(1, 0), 8), 5) Then
            s = s & "Отп." & Left(Right(aCell, 8), 3) & " оп." & aCell.Offset(0, -1) & "; "
        Else
            s = s & aCell.Offset(0, -1) & "; "
        End If
    End If
    Next
        If s <> "" Then
              Cells(2, 2) = Application.Trim(s)
            s = ""
        End If
Next
End Sub

Sub Сбор_хран2()
Dim wb As Workbook, s, a, k, h, i As Long, st As String, x, b
Dim t As String, th As String, ns As String, sh As String, hr As String
        Set wb = ThisWorkbook
        a = wb.Sheets(2).UsedRange
        Set k = CreateObject("Scripting.Dictionary")
        Set h = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a)
            If k.exists(a(i, 4)) Then GoTo Sled
            k.Item(a(i, 4)) = 0
            s = Split(a(i, 4), "-")
            t = s(0) & "-" & s(1)
            th = s(0) & "-" & s(1) & "-" & s(2)
            ns = (a(i, 3))   ' Номера полок из третьего столбца исходных данных
            If h.exists(th) Then
                sh = h.Item(th) & "; " & ns
            Else
                hr = IIf(.exists(t), ";", "")
                .Item(t) = .Item(t) & hr & th
                sh = IIf(Val(s(2)) >= 500, "Отп." & s(2) & " оп.", "") & ns
            End If
            h.Item(th) = sh
Sled:
        Next
        i = 1
        For Each x In .keys
            s = Split(.Item(x), ";")
            st = ""
            For Each b In s
                st = st & IIf(st = "", "", "; ") & h.Item(b)
            Next
                If Not wb.Sheets(1).Columns(3).Find(x, , , xlWhole) Is Nothing Then
                ' Ищем в листе 1 "Место общее" и добавляем номера полок, которые есть вэтом месте. Предварительно убрав лишний текст
                    wb.Sheets(1).Cells(wb.Sheets(1).Columns(3).Find(x, , , xlWhole).Row, 2) = Replace(st, "Полка № ", "")
                    i = i + 1
                End If
        Next
    End With
End Sub