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

[iceggg]

Код (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 Cells(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
        End If
    Next
    .Cells(2, 1).Resize(S, UBound(MiArr, 2)).Value = MiArr
End With
End Sub

Только так он все строки с 0 в 10 столбце просто пропускает и не добавляет в новый массив. А надо что бы он их переносил не разделяя. Я думал что условие то сам смогу прикрутить но в этом макросе вообще ничего не понимаю не знаю куда его тут поставить что бы нормально работало.

[Михаил С.]

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

Благодарю так работает.