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

[iceggg]

Здравствуйте. Нужна помощь с макросом. Есть таблица в ней в 13(M) столбце стоят числа надо пройтись по всей таблице скопировать строки и вставить ниже под текущей такое количество раз как число в 13 столбце текущей строки и что бы во всех вставленных строках и текущей в итоге в 13 столбце стало число 1.  Я попробовал написать макрос но так как в них не силен заблудился и застрял.
Получилась такая ерунда:

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

Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1

For x = 2 To EndRow
  p1 = Cells(x, 13).Value
  If Cells(x, 13) > 1 Then
   c = p1 - 1
    Row.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell
2:
    End If
     Cells(x, 13).Select
     If c > 1 Then GoTo 1
      Next x
     
1:
   c = Cells(x, 13).Value - 1
    Row.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1 + f
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell
    f = f + 1
    GoTo 2
   
End Sub

Похоже оно не жизнеспособно. Выдает ошибку и выделяет желтым строку Row.Select

[A-Michael]

Этот вариант у Вас не пройдёт, попробуйте что-то типа: Rows(ActiveCell.Row).Select

[iceggg]

Ага эту строчку прошло спасибо. Подскажите еще вот с этой частью:

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

    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell


теперь тут на строку Cells.Value = c ругается желтым.

[Alexander88]

Так:

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

Cell.Value = c

[iceggg]

Извините это я туплю мог бы и сам заметить что буква лишняя.

[iceggg]

Он заработал но лучше бы не работал . Выполняется до бесконечности и разносит всю таблицу в клочья. Подскажите в чем причина.

[iceggg]

Похоже нижняя часть после 2: выполняется до бесконечности. Как сделать что бы он не лез туда когда не надо?

[A-Michael]

У Вас происходит элементарное зацикливание из-за использования переходов, если Вы только не изменили код. Выложите новый вариант, если не трудно.

[iceggg]

Вот:

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

[Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1

For x = 2 To EndRow
  p1 = Cells(x, 13).Value
  If Cells(x, 13) > 1 Then
   c = p1 - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1
    For Each Cell In Range(Cells(d, 13), Cells(x, 13))
    Cell.Value = c
    Next Cell
2:
    End If
     Cells(x, 13).Select
     If c > 1 Then GoTo 1
      Next x
     
1:
   c = Cells(x, 13).Value - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1 + f
    For Each Cell In Range(Cells(d, 13), Cells(x, 13))
    Cell.Value = c
    Next Cell
    f = f + 1
    GoTo 2
   
End Sub

/code]

[A-Michael]

Как я понял сама концепция алгоритма ошибочна. У Вас получается, что EndRow не изменяется, она используется для определения конца цикла. А в процессе работы Вы добавляете строки не в конце таблицы, а прямо в тело и когда доходите до EndRow строки у Вас получается не конец таблицы, а, грубо говоря, середина. Вам необходимо продумать этот вопрос.
Например, использовать вставку строки в начале таблицы и при этом наращивать счётчик строк на 1. А конец таблицы определять по отсутствию данных. Например так: If cells(N_Row,1)="" then ..., где N_Row счётчик строк.

[iceggg]

Строки надо вставлять обязательно под текущей строкой. А не подскажете еще куда и как прикрутить If cells(N_Row,1)="" then ..., ?

[A-Michael]

По первой части вопроса - может быть есть какой-нибудь идентификатор (определитель) по которому потом, после работы программы, можно отсортировать данные?
По второй части - "прикрутить" проверку можно в начале цикла, хотя эта операцию уже циклом назвать трудно, и по истине (True) выходить из подпрограммы.

[iceggg]

Нет идентификатора никакого нет строки с одинаковыми записями могут быть в другой части таблицы. Похоже я как то неправильно приделал.

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

Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1
N_Row = 2

4:
If Cells(N_Row, 1) = "" Then GoTo 3
  p1 = Cells(N_Row, 13).Value
  If Cells(N_Row, 13) > 1 Then
   c = p1 - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = N_Row + 1
    For Each Cell In Range(Cells(d, 13), Cells(N_Row, 13))
    Cell.Value = c
    Next Cell
2:
    End If
     Cells(N_Row, 13).Select
     If c > 1 Then GoTo 1
     If Cells(N_Row, 1) = "" Then GoTo 3
      N_Row = N_Row + 1
      GoTo 4
1:
   c = p1 - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    g = g + 1
    d = N_Row + 1 + f
    For Each Cell In Range(Cells(d, 13), Cells(N_Row, 13))
    Cell.Value = c
    Next Cell
    f = f + 1
    GoTo 2
3:
End Sub



Оно заменяет в 13 столбце все числа начиная с 3 строки на 2 и стоит на 2 строке дергается до бесконечности.

[A-Michael]

А как Вы думаете, если у Вас переход на метку 4 возвращает всё в самое начало? Попробуйте обойтись вообще без переходов GoTo и в будущем не злоупотребляете безусловными переходами.

[Alexander88]

Ели правильно понял:

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

Sub qq()
Dim i As Integer, j As Integer, n As Integer
n = Cells(2, 1).End(xlDown).Row
For i = 2 To n
    For j = 1 To Cells(i, 13) - 1
        n = n + 1
        Range(Cells(n, 1), Cells(n, 16)) = Range(Cells(i, 1), Cells(i, 16)).Value
    Next j
Next i
Range(Cells(2, 13), Cells(n, 13)) = 1
End Sub