Друзья, здравствуйте!
Извините, что долго молчу - пока еще тяжело писать.
Огромнейшее спасибо за помощь - всего около 70 т руб.
Благодаря вам - прошел нужные обследование и основной курс терапии.
Читать немного получается, писать учусь по-новой.
Еще раз -огромное спасибо за помощь, сейчас немного полегче.
Такой острой нужды сечас уже нет, и было бы не честно об этом не сказать.

Друзья огромное спасибо за помощь!
Благодаря вам у меня появился шанс - сейчас прохожу курс интенсивной терапии, о результатх пока говорить рано.
Спасибо!

Ребята, я сейчас в таком положении, что буду благодарен любой помощи.
Спасибо.

Код: (vb)

Sub Insert_Row_iceggg()
Dim Arr(), MiArr(), i&, ii&, k&, S&
With Worksheets(1)
    Arr = .UsedRange.Value
    S = WorksheetFunction.Sum(.Range(.Cells(2, 13), .Cells(.Rows.Count, 13).End(xlUp)))
    ReDim MiArr(1 To S, 1 To UBound(Arr, 2))
    k = 1
    For i = 2 To UBound(Arr)
        If Arr(i, 10) <> 0 Then
            For k = k To k + Arr(i, 13) - 1
                For ii = 1 To UBound(Arr, 2)
                    MiArr(k, ii) = Arr(i, ii)
                Next
                MiArr(k, 13) = 1
            Next
        Else
            For ii = 1 To UBound(Arr, 2)
                MiArr(k, ii) = Arr(i, ii)
            Next
            k = k + 1
        End If
    Next
    .Cells(2, 1).Resize(S, UBound(MiArr, 2)).Value = MiArr
End With
End Sub

[iceggg]

iceggg, давайте подробнее, что у вас не получается, и с примером - что есть, что надо.

Вы проверили с исправлениями?

[S]

Понятно. Ошибка  в строке вычисления S Должно быть:
  

Код: (vb)

 S = WorksheetFunction.Sum(.Range(.Cells(2, 13), .Cells(.Rows.Count, 13).End(xlUp)))

зы. но если в файле есть скрытые строки (последние) или числа в тестовом формате - то нужен дрeгой алгоритм подсчета S

Пример можете показать, с пустыми строками, с ошибкой <Subscript out of range>.?

Во второй S=1 488 931 827

S - это количество строк; на листе всего 1 048 576 строк, куда вы столько поместите (полтора миллиарда)?

Еще заметил если в одном из столбцов есть пустые ячейки то выходит ошибка <Subscript out of range>.

Здесь непонятно. весь столбец пустой? или отдельные ячейки пустые? в принципе, не пустые. не нулевые ячейки в 13 столбце не мешают - просто эти строки не переносятся.
В других столбцах вообще роли нет.

[А1]

Да, и еще... Мой код подразумевает, что на листе, кроме таблицы нет посторонних данных.
Если вы "экономите" листы, и кроме этой таблицы есть и другие - тогда код нужно немного переделать.
Конкретно, строку  

Код: (vb)

 Arr = .UsedRange.Value 

заменить на  

Код: (vb)

Arr = .Range("A1").CurrentRegion.Value 

здесь А1 - любая не пустая ячейка из нужной таблицы

И еще в другой таблице на 6 строке кода выдает ошибку <Out of memory>. Таблица такая же только там данных больше.

Плохо. Не хватает памяти для массивов.
Обрабатывать по частям - усложнит код, но обработка массивов на порядки быстрее работы по-ячеечно.
Сколько строк в первом массиве, и сколько строк должно получиться во втором, когда получается ошибка?

Код: (vb)

Sub Insert_Row_iceggg()
Dim Arr(), MiArr(), i&, ii&, k&, S&
With Worksheets(1)
'берем в массив все данные первого листа
    Arr = .UsedRange.Value '
'считаем сумму по 13 столбцу - для определения, сколько стоко будет всего
    S = WorksheetFunction.Sum(.Range(.Cells(2, 13), Cells(.Rows.Count, 2).End(xlUp)))
'Назанчаем размеры нового (конечного) массива
    ReDim MiArr(1 To S, 1 To UBound(Arr, 2))
    k = 1 ' начальное значение переменной. Определяет строку конечного массива
    For i = 2 To UBound(Arr) 'идем по строкам исходного массива, начиная с строки 2
        For k = k To k + Arr(i, 13) - 1
'в элемете Arr(i,13) - количество повтора строк, столько раз повторится строка i первого массива
            For ii = 1 To UBound(Arr, 2)
'переносим из строки i первого массива в строку k второго массива
                MiArr(k, ii) = Arr(i, ii)
            Next
            MiArr(k, 13) = 1 ' присваиваем значению в 13 стобце значение 1
        Next
    Next
'Выгружаем конечный массив на лист, начиная со второй строки
    .Cells(2, 1).Resize(S, UBound(MiArr, 2)).Value = MiArr
End With
End Sub

Хотелось бы посмотреть файл, в котором появляется эта ошибка.
зы. Она может появляться, только если в 13 столбце есть нули, или числа прописаны как текст (тогда Sum считает неверно).

Код: (vb)

Sub Insert_Row_iceggg()
Dim Arr(), MiArr(), i&, ii&, k&, S&
With Worksheets(1)
    Arr = .UsedRange.Value
    S = WorksheetFunction.Sum(.Range(.Cells(2, 13), Cells(.Rows.Count, 2).End(xlUp)))
    ReDim MiArr(1 To S, 1 To UBound(Arr, 2))
    k = 1
    For i = 2 To UBound(Arr)
        For k = k To k + Arr(i, 13) - 1
            For ii = 1 To UBound(Arr, 2)
                MiArr(k, ii) = Arr(i, ii)
            Next
            MiArr(k, 13) = 1
        Next
    Next
    .Cells(2, 1).Resize(S, UBound(MiArr, 2)).Value = MiArr
End With
End Sub

Усреднить по каждой строке, или по всем строкам сразу?
Покажите пример результата.