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

[iceggg]

A-Michael

Попробовал убрать goto получилось вот это:

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

Sub azaz()

f = 1
N_Row = 2

For Each Cell In Range("M:M")
 
  If Cells(N_Row, 1) <> "" Then
    p1 = Cells(N_Row, 13).Value
     
      If Cells(N_Row, 13) > 1 Then
        c = p1 - 1
        Cells(N_Row, 13).Select
        Rows(ActiveCell.Row).Select
        Selection.Copy
        Selection.Insert Shift:=xlDown
        d = N_Row + 1
        Cells(d, 13).Value = c
        Cells(N_Row, 13).Select
      End If
     
      If c > 1 Then
        c = p1 - 1
        Rows(ActiveCell.Row).Select
        Selection.Copy
        Selection.Insert Shift:=xlDown
        d = N_Row + 1 + f
        Cell(d, 13).Value = c
        Cells(d, 13).Select
        Selection.AutoFill Destination:=Range(Cells(d, 13), Cells(N_Row, 13)), Type:=xlFillDefault
        Range(Cells(d, 13), Cells(N_Row, 13)).Select
        Cells(N_Row, 13).Select
        f = f + 1
      End If
     
     
  N_Row = N_Row + 1
  End If
 
Next Cell
   
End Sub


но оно срабатывает плохо копирует но не меняет числа до единице в 13 столбце и в итоге его все равно переклинивает и оно бесконечно долго ползет по строчкам.

Alexander88

Ваш вариант проходит и отлично заменяет все цифры в 13 столбце на единицы но строчки копирует далеко не все никак не пойму как он работает но вродебы копирует только те где цифра стоит больше 5 или 10 в остальных просто заменяет цифру на 1.

[Alexander88]

В моём макросе цифры меняются в десятой строке кода
Покажите на втором листе, какой должен быть результат

[iceggg]

Вот лист1 пример таблицы лист2 конечный результат который должен получиться на листе1.

[Alexander88]

Не пойму, чем мой макрос не подходит..
С сортировкой и форматом ячеек надеюсь справитесь

[iceggg]

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

[iceggg]

Выходит что то вроде этого:

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

Sub azaz()

Dim i As Integer, n As Integer

n = Cells(2, 1).End(xlDown).Row

For i = 2 To n
     p1 = Cells(i, 13).Value
     f = 1

  If p1 <> 1 Then
     n = n + 1
     p1 = p1 - 1
     Cells(i, 13).Value = p1
     Cells(i, 13).Select
     Rows(ActiveCell.Row).Select
     Selection.Copy
     Selection.Insert Shift:=xlDown
     d = i + 1
     Cells(i, 13).Select
     Selection.AutoFill Destination:=Range(Cells(i, 13), Cells(d, 13)), Type:=xlFillDefault
     Range(Cells(i, 13), Cells(d, 13)).Select
   End If

1:

  If p1 <> 1 Then
     n = n + 1
     p1 = p1 - 1
     Cells(i, 13).Value = p1
     Cells(i, 13).Select
     Rows(ActiveCell.Row).Select
     Selection.Copy
     Selection.Insert Shift:=xlDown
     d = i + 1 + f
     Cells(i, 13).Select
     Selection.AutoFill Destination:=Range(Cells(i, 13), Cells(d, 13)), Type:=xlFillDefault
     Range(Cells(i, 13), Cells(d, 13)).Select

   If p1 <> 1 Then
     f = f + 1
     GoTo 1
   End If

   End If
 
Next i
   
End Sub
Но оно доходит до первоначально заданного n и втыкается. Если через f8 продолжить выполнение макроса то идет дальше проходит заданное число ячеек и снова уходит в end sub.

[Alexander88]

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

Sub qq()
Dim i As Integer, j As Integer
i = 2
Do
    j = Cells(i, 13)
    If j > 1 Then
        Range(Cells(i, 1), Cells(i, 16)).Copy
        Range(Cells(i, 1), Cells(j + i - 2, 1)).Insert Shift:=xlDown
    End If
    i = i + j
Loop Until IsEmpty(Cells(i, 1))
Application.CutCopyMode = False
Range(Cells(2, 13), Cells(i - 1, 13)) = 1
End Sub

[iceggg]

Хм... отлично сработал на маленькой таблице но если в таблице много строк вешается эксель.

[Alexander88]

Попробуйте отключить обновление экрана, пересчет формул и т.д.
Возможно есть смысл очищать буфер после каждой вставки

[iceggg]

Так работает получше:

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

Sub qq()

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

Dim i As Integer, j As Integer
i = 2
Do
    j = Cells(i, 13)
    If j > 1 Then
        Application.CutCopyMode = True
        Range(Cells(i, 1), Cells(i, 16)).Copy
        Range(Cells(i, 1), Cells(j + i - 2, 1)).Insert Shift:=xlDown
        Application.CutCopyMode = False
    End If
    i = i + j
Loop Until IsEmpty(Cells(i, 1))
Application.CutCopyMode = False
Range(Cells(2, 13), Cells(i - 1, 13)) = 1

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

End Sub

Но все равно эксель подвисает на минуту примерно при 6000 строк и грузит проц (Intel i5) на 38%для тормозных компов будет совсем печально. В связи с этим такой вопрос можно ли сделать как то что бы не вешался эксель и проц грузился поменьше ?

[Alexander88]

Нужно избавляться от копирования-вставки, см. №14
Можно попробовать без обновления экрана и пересчета:
[spoiler]

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

Sub qq()
Dim i As Integer, j As Integer
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayStatusBar = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With
i = 2
Do
    j = Cells(i, 13)
    If j > 1 Then
        Range(Cells(i, 1), Cells(i, 16)).Copy
        Range(Cells(i, 1), Cells(j + i - 2, 1)).Insert Shift:=xlDown
        Application.CutCopyMode = False
    End If
    i = i + j
Loop Until IsEmpty(Cells(i, 1))
Range(Cells(2, 13), Cells(i - 1, 13)) = 1
With Application
    .EnableEvents = True
    .DisplayStatusBar = True
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub[/spoiler]

[iceggg]

Разницы практически нет. Как можно выполнить подобную задачу без копирования-вставки не представляю даже приблизительно.

[iceggg]

Если копировать как в моем варианте по 1 строке то эксель не виснет. Вероятно в этом варианте проблема в том что он копирует сразу много строк. Там в некоторых строках стоят числа по 100  и больше.

[iceggg]

Но в моем варианте он обрабатывает только 30 строк примерно а потом ломается.

[Alexander88]

Так попробуйте:

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

Sub qq()
Dim i As Integer, j As Integer, n As Integer, k As Integer, isum As Integer
n = Cells(2, 1).End(xlDown).Row                                                         'последняя строка
isum = Application.Sum(Range(Cells(2, 13), Cells(n, 13)))                               'сумма в 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                                           'изменение значений на 1
Range(Cells(2, 1), Cells(n, 16)).Delete Shift:=xlUp                                     'удаление старой таблицы
End Sub