Подсчет и вывод результата...

[sew960i]

Ну вообщем это должны быть размеры...
38,39,40,41,42,43,44,45,46,47,
Но чтоб меньше занимало места решили сократить до
8,9,0,1,2,3,4,5,6,7,

[EducatedFool]

Попробуйте такой вариант:

Function Остаток(ByRef ra As Range) As String
    Dim cell As Range, n As String, txt As String
    For Each cell In ra.Cells: txt = txt & cell.Text & ",": Next cell
    arr = Split(Replace(Replace(txt, ",,", ","), " ", ""), ",")
    For i = LBound(arr) To UBound(arr)
        If Len(arr(i)) Then
            n = Replace("-" & arr(i), "--", "")
            For j = i + 1 To UBound(arr)
                If arr(j) = n Then arr(i) = "": arr(j) = "": Exit For
            Next j
        End If
    Next i
    MyQuickSort arr
    For i = LBound(arr) To UBound(arr)
        If IsNumeric(arr(i)) Then arr(i) = arr(i) Mod 10
    Next i
    Остаток = Replace(Application.Trim(Replace(Join(arr, ","), ",", " ")) & " ", " ", ",")
End Function

Пример файла:

[sew960i]

Пишет:
Compile error
Sub of function not defined...
--------------------------------
И ясли я буду писать в ячейках
не 48,49,50 а 8,9,0 и тд (в сокращенном виде)...
будет правильно считать?

[EducatedFool]

Сообщение от sew960i

Пишет:
Compile error
Sub of function not defined...

Я привёл код только изменённого макроса.
Функция сортировки осталась без изменений - её код скопируйте из предыдущего поста.

Есть же пример в файле - там же всё работает...

Сообщение от sew960i

И ясли я буду писать в ячейках
не 48,49,50 а 8,9,0 и тд (в сокращенном виде)...
будет правильно считать?

Нет.

Код сейчас обрабатывает полные размеры ( 48,49,50 )
после чего их сортирует по возрастанию, а затем оставляет только последние цифры от результата
(каждое число заменяется его остатком от деления на 10)

[sew960i]

все работает...
Только мне нужно заполнять ячейки не в таком виде
38,39,40,41,42,43,44,45,46,47, и тд...
а в таком...
8,9,0,1,2,3,4,5,6,7,
Я просто уже привык так... и места занимает в ячейке меньше...
Возможно это?

[EducatedFool]

А что, размеры встречаются только такие?

38,39,40,41,42,43,44,45,46,47

Не попадаются размеры меньше 38 и больше 47?
Если попадаются, то как они будут записываться?

[sew960i]

нет... меньше 38 и больше 47 не попадаются...
только 38,39,40,41,42,43,44,45,46,47

[EducatedFool]

Тогда так:

Function Остаток(ByRef ra As Range) As String
    Dim cell As Range, n As String, txt As String
    For Each cell In ra.Cells: txt = txt & cell.Text & ",": Next cell
    arr = Split(Replace(Replace(txt, ",,", ","), " ", ""), ",")
    For i = LBound(arr) To UBound(arr)
        If Len(arr(i)) Then
            n = Replace("-" & arr(i), "--", "")
            For j = i + 1 To UBound(arr)
                If arr(j) = n Then arr(i) = "": arr(j) = "": Exit For
            Next j
        End If
    Next i
    For i = LBound(arr) To UBound(arr)
        If IsNumeric(arr(i)) Then
            arr(i) = IIf(Val(Right(arr(i), 1)) > 7, "3", "4") & arr(i)
        End If
    Next i
    MyQuickSort arr
    For i = LBound(arr) To UBound(arr)
        If IsNumeric(arr(i)) Then arr(i) = arr(i) Mod 10
    Next i
    Остаток = Replace(Application.Trim(Replace(Join(arr, ","), ",", " ")) & " ", " ", ",")
End Function


Sub MyQuickSort(arr, Optional First As Long = -1, Optional Last As Long = -1)
    On Error Resume Next    ' Быстрая сортировка, [Q]uick [S]ort
    Dim i As Long, j As Long, MidEl As Variant, t As Variant
    First = IIf(First = -1, LBound(arr), First)
    Last = IIf(Last = -1, UBound(arr), Last)
    i = First: j = Last: MidEl = arr((First + Last) \ 2)
    Do While i <= j
        If arr(i) < MidEl Then
            i = i + 1
        Else
            If arr(j) > MidEl Then
                j = j - 1
            Else
                t = arr(i): arr(i) = arr(j): arr(j) = t: i = i + 1: j = j - 1
            End If
        End If
    Loop
    If First < j Then Call MyQuickSort(arr, First, j)
    If i < Last Then Call MyQuickSort(arr, i, Last)
End Sub

Пример файла:



PS: Все остальные доработки (если понадобятся) - за дополнительную плату.

[sew960i]

Спасибо!!! Все работает!!!