Копирование и добавления строк в зависимости от числа в ячейке.

[iceggg]

Не срабатывает на строке 06 выдает ошибку Cells(n + isum, 16) = <Overflow>.

[Alexander88]

Какие значения у переменных n и isum?
Попробуйте тип Long, вместо Integer

[iceggg]

n=6150 isum=3040

[Alexander88]

Т.е. у Вас в 13 столбце таблицы 6150 ячеек и их сумма 3040?
Почитайте на досуге про переменные

[iceggg]

Написал то что выдал эксель когда наводиш на переменные курсор после ошибки.

[iceggg]

Все работает правда переделывает всю таблицу но с задачей справляется и быстро.

Код (vb) Выделить Развернуть

Sub qq()

Dim i As Integer, j As Integer, n As Long, k As Integer, isum As Long

Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

n = Cells(2, 1).End(xlDown).Row                                                         
isum = Application.Sum(Range(Cells(2, 13), Cells(n, 13)))                               
Range(Cells(2, 1), Cells(2, 16)).Copy                                                   
Range(Cells(n + 1, 1), Cells(n + isum, 16)).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
k = n + 1                                                                               
For i = 2 To n
    j = Cells(i, 13)
    Range(Cells(k, 1), Cells(k + j - 1, 16)) = Range(Cells(i, 1), Cells(i, 16)).Value   
    k = k + j
Next i
Range(Cells(n + 1, 13), Cells(k - 1, 13)) = 1                                           
Range(Cells(2, 1), Cells(n, 16)).Delete Shift:=xlUp                                     

Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True

End Sub


Спасибо всем за помощ думаю тема закрыта.

[Михаил С.]

Код (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


[iceggg]

Тут все сложно для меня не понимаю где что происходит. Но на 11 строке выдает ошибку <subscript out of range>.

[Михаил С.]

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

[iceggg]

В 13 столбце были оказывается строки выходящие за пределы таблицы. После их удаления все работает.
А можете выложить тот же макрос с пояснениями где что выполняется ?

[iceggg]

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

[Дмитрий Щербаков(The_Prist)]

Ошибка значит, что памяти недостаточно. Слишком большой массив данных. Либо частями обрабатывать, либо напрямую в ячейках.

[Михаил С.]

Код (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


[Михаил С.]

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

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

[Михаил С.]

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

Код (vb) Выделить Развернуть

Arr = .UsedRange.Value заменить на  

Код (vb) Выделить Развернуть

Arr = .Range("A1").CurrentRegion.Value
здесь А1 - любая не пустая ячейка из нужной таблицы