Как разбить числовой ряд на отдельные ячейки

[Hugo121]

Код тёзки конечно хорош, но из-за универсальности и доп.опций большой и непонятный
Если тренироваться на конкретно этих "рогах и копытах", то можно сделать иначе и проще (алгоритм как я выше описал, только выгрузка сюда же):

Option Explicit

Sub Razlozitj()
    Dim a(), i&, ii&, poz&, temp
    a = [a1].CurrentRegion.Value
    [a1].CurrentRegion.Clear
    poz = 1
    For i = 1 To UBound(a)
        temp = Split(a(i, 2), ",")
        ReDim b(1 To UBound(temp) + 1, 1 To 2)
        For ii = 1 To UBound(b)
            b(ii, 1) = a(i, 1)
            b(ii, 2) = Trim(temp(ii - 1))
        Next
        Cells(poz, 1).Resize(ii - 1, 2) = b
        poz = poz + ii - 1
    Next
End Sub

[jhenya-d]

спасибо, я пытался , просто файл выложил пустой,
больше работал с функциями, а не со скриптами

[jhenya-d]

нашел корявый способ без макросов
снчала разбиваем числа на ячейки
внизу таблицы создаем еще одну фиксируем первую ячейку и сцепляем ее со всеми что справа, то-есть протягиваем вправо, а потом вниз

правда потом выстроить в одну табличку ручками, если их мало не проблема

[АННА-ЕАО]

Всем здравствуйте .

Hugo121 Подскажите пожалуйста. Если в моём случае числовые данные распологаются не через запятую (как в примере у jhenya-d), а находятся в отдельной ячейки, что нужно изменить и/или добавить к Вашему коду, что бы результат был таким же.

Пример:

[Hugo121]

Анна, для Вас такой вариант:

Option Explicit

Sub Razlozitj()
    Dim a(), i&, ii&, poz&
    Application.ScreenUpdating = False
    
    a = [a1].CurrentRegion.Value
    '[a1].CurrentRegion.Clear 'если нужно, активируйте
    poz = 53 'тут вписываете номер первой строки выгрузки
    Cells(poz, 1) = a(1, 1)
    poz = poz + 1
    For i = 2 To UBound(a, 1)
        ReDim b(1 To UBound(a, 2) - 1, 1 To 3)
        For ii = 1 To UBound(b)
            b(ii, 1) = a(i, 1)
            b(ii, 2) = a(1, ii + 1)
            b(ii, 3) = a(i, ii + 1)
        Next
        Cells(poz, 1).Resize(ii - 1, 3) = b 'выгружаем
        Range(Cells(poz + ii - 2, 1), Cells(poz + ii - 2, 3)).Font.Bold = True 'делаем жирным
        poz = poz + ii - 1
    Next
    
    Application.ScreenUpdating = True

End Sub

Но выделение жирным не копируется - я его ставлю принудительно на последнюю строку выгруженного массива.

Если нужно рамку - то сперва обводим заголовок отдельно, потом запоминаем в переменную начальную строку выгрузки, после выгрузки от этой переменной до poz-1 тянем рамку на 3 столбца.

[Казанский]

Последняя секция "Итого" ИМХО не нужна.
Работает с выделенным диапазоном, результат на новом листе.

Sub Anna()
Dim x(), i&, j&, k&
x = Selection.Value
ReDim v(1 To (UBound(x) - 2) * (UBound(x, 2) - 1) + 2, 1 To 3)
v(1, 1) = x(1, 1)
k = 2
For i = 2 To UBound(x) - 1
    For j = 2 To UBound(x, 2)
        v(k, 1) = x(i, 1)
        v(k, 2) = x(1, j)
        v(k, 3) = x(i, j)
        k = k + 1
    Next
Next
v(UBound(v), 1) = x(i, 1)
v(UBound(v), 3) = x(i, UBound(x, 2))
Worksheets.Add.Cells(1, 1).Resize(UBound(v), UBound(v, 2)).Value = v
For i = UBound(x, 2) To k Step UBound(x, 2) - 1
    Rows(i).Font.Bold = True
Next
Rows(k).Font.Bold = True
End Sub

[Hugo121]

Да, в варианте Анны заранее известен размер итогового массива, поэтому код Казанского быстрее и лучше
Я же переделывал существующий код, где это было заранее неизвестно... и это ошибка
Но работает...

[АННА-ЕАО]

Hugo121 , Казанский Большущее Вам спасибо! Оба кода работают