Sub Макрос2()
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("A3:J" & lr)
    ReDim arr_rez(1 To UBound(arr), 1 To 5)
    Set sd_t = CreateObject("Scripting.Dictionary")
    Set sd_n = CreateObject("Scripting.Dictionary")
    For n = 1 To UBound(arr)
        For m = 7 To 10
        If arr(n, m) <> "" Then
            If Not sd_t.Exists(arr(n, m)) Then Set sd_t(arr(n, m)) = CreateObject("Scripting.Dictionary")
            If Not sd_t(arr(n, m)).Exists(arr(n, 2)) Then sd_t(arr(n, m)).Add arr(n, 2), arr(n, 2)
            If Not sd_n.Exists(arr(n, 2)) Then Set sd_n(arr(n, 2)) = CreateObject("Scripting.Dictionary")
            If Not sd_n(arr(n, 2)).Exists(arr(n, m)) Then sd_n(arr(n, 2)).Add arr(n, m), arr(n, m)
        End If
        Next
    Next
    For n = 1 To UBound(arr)
        m = 1
        Set sd_r = CreateObject("Scripting.Dictionary")
        For Each y In sd_n(arr(n, 2))
            For Each y1 In sd_t(y)
                If y1 <> arr(n, 2) Then
                If Not sd_r.Exists(y1) Then sd_r.Add y1, y1
                End If
            Next
            arr_rez(n, m) = y
            m = m + 1
        Next
        arr_rez(n, 5) = Join(sd_r.Keys, "; ")
    Next
    Range("K3").Resize(UBound(arr_rez), 5) = arr_rez
End Sub