Function Sort1(SheetRange1 As Range, SheetRange2 As Range)
Dim Temp, DataPrimary, DataSlave, Result(), ResultText(), IndexP, i&, j&, k&, x&, m&

'задаю массиву значения диапазона
DataPrimary = SheetRange1.Value
DataSlave = SheetRange2.Value

IndexP = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j")

'удаляю дубли
For i = LBound(DataPrimary) To UBound(DataPrimary) - 1
    For j = i + 1 To UBound(DataPrimary)
        If DataPrimary(i, 1) = DataPrimary(j, 1) And DataPrimary(i, 1) <> 0 Then DataPrimary(j, 1) = 0
    Next j
Next i

'расставляю по возрастанию
For i = LBound(DataPrimary) To UBound(DataPrimary) - 1
    For j = i + 1 To UBound(DataPrimary)
        If DataPrimary(i, 1) > DataPrimary(j, 1) Then
            Temp = DataPrimary(i, 1)
            DataPrimary(i, 1) = DataPrimary(j, 1)
            DataPrimary(j, 1) = Temp
        End If
    Next j
Next i

'переопределяю размерность массива без нулей
For i = LBound(DataPrimary) To UBound(DataPrimary)
    If DataPrimary(i, 1) > 0 Then x = x + 1
Next i
ReDim Result(1 To x, 1 To 11)

'переношу данные без нулей в верном порядке
For i = x To 1 Step -1
    Result(i, 1) = DataPrimary(i + UBound(DataPrimary) - UBound(Result), 1)
Next i

'выстраиваю двемерный массив типов и ширин
DataPrimary = SheetRange1.Value
For i = LBound(Result) To UBound(Result)
    For j = LBound(DataPrimary) To UBound(DataPrimary)
        If Result(i, 1) = DataPrimary(j, 1) Then
            For k = 2 To 11
                Result(i, k) = Result(i, k) + DataSlave(j, k - 1)
            Next k
        End If
    Next j
Next i

'считаю количество строк ответа
x = 0
For i = LBound(Result) To UBound(Result)
    For j = 2 To 11
        If Result(i, j) > 0 Then x = x + 1
    Next j
Next i
ReDim ResultText(1 To x, 1 To 1)

'собираю массив конечного ответа
For i = LBound(ResultText, 1) To UBound(ResultText, 1)
    For j = LBound(Result, 1) To UBound(Result, 1)
        If Result(j, 1) > 0 Then
            For k = 2 To 11
                If Result(j, k) > 0 Then
                    ResultText(i, 1) = Result(j, 1) * 10 & "-" & IndexP(k - 2)
                    Result(j, k) = 0
                    GoTo NextResult
                End If
            Next k
        End If
    Next j

NextResult:
    x = 0
    For k = 2 To 11
        If Result(j, k) > 0 Then x = x + 1
    Next k
    If x = 0 Then Result(j, 1) = 0
Next i

Sort1 = ResultText
End Function

Function Sort(SheetRange As Range) As Variant
Dim Temp As Variant, i As Byte, j As Byte, x As Byte, Result() As Variant, Data As Variant

'задаю массиву значения диапазона
Data = SheetRange.Value

'расставляю по возрастанию
For i = LBound(Data) To UBound(Data) - 1
    For j = i + 1 To UBound(Data)
        If Data(i, 1) > Data(j, 1) Then
            Temp = Data(i, 1)
            Data(i, 1) = Data(j, 1)
            Data(j, 1) = Temp
        End If
    Next j
Next i

'переопределяю размерность массива без нулей
For i = LBound(Data) To UBound(Data)
    If Data(i, 1) > 0 Then x = x + 1
Next i
ReDim Result(1 To x, 1 To 1)

'переношу данные без нулей в верном порядке
For i = x To 1 Step -1
    Result(i, 1) = Data(i + UBound(Data) - UBound(Result), 1)
Next i

Sort = Result
End Function

Function Sort1(MyRange2 As Variant) As Variant 'не работает
'расставляю по возрастанию
Dim Temp As Variant, i As Byte, j As Byte, x As Byte, MyRange() As Variant
For i = LBound(MyRange2) To UBound(MyRange2) - 1
    For j = i + 1 To UBound(MyRange2)
        If MyRange2(i, 1) > MyRange2(j, 1) Then
            Temp = MyRange2(i, 1)
            MyRange2(i, 1) = MyRange2(j, 1)
            MyRange2(j, 1) = Temp
        End If
    Next j
Next i

'переопределяю размерность массива без нулей
For i = LBound(MyRange2) To UBound(MyRange2)
    If MyRange2(i, 1) > 0 Then x = x + 1
Next i
ReDim MyRange(1 To x)

'переношу данные без нулей в верном порядке
For i = UBound(MyRange) To LBound(MyRange) Step -1
    MyRange(i) = MyRange2(i + UBound(MyRange2) - UBound(MyRange), 1)
Next i

Sort1 = MyRange
End Function