Добавление строку

[Aqil_f]

Помогите пожалуйста мне, в одной сложной задаче для меня.

В Excel есть 1 столбец в следующим виде:

00901005
00902003
00901011
00903006
00902025
01101013
01103047
01102033
01102021
01104025
01101051

Мне надо взять последные 3 символу в каждом строке и в столько раз добавить каждую строку. Как можно делать такое? Помогите пожалуйста.

[IgorGO]

положите в модуль листа и выполните этот

Sub AddSameRows()
  Dim r As Long, n As Long
  r = 1
  Do While Not IsEmpty(Cells(r, 1))
    n = Val(Right(Cells(r, 1), 3))
    If n > 0 Then Rows(r + 1).Resize(n).Insert
    r = r + n + 1
  Loop
End Sub

[Aqil_f]

Спасибо, IgorGO.
Только 1-я строка почему-то 10 раз добавляется (а должна 5 раз) и еще можно делать так что сама запись (00901005, 00901003) тоже добавлялся в эту пустую строку?

[AleksandrH]

Ну и наивный вариант от меня

Sub ttt()
    Dim i As Integer, j As Integer, lr As Long, c As Integer
    i = 1: lr = Range("A65535").End(xlUp).Row
    Do While i <= lr
        c = Int(Right(Cells(i, 1).Value, 3))
        For j = 2 To c
            Cells(i, 1).Copy
            Cells(i + j - 1, 1).Insert Shift:=xlDown
        Next j
        i = i + c
        lr = Range("A65535").End(xlUp).Row
    Loop
End Sub

[IgorGO]

если выполните макрос еще разок - первая строка почемуто добавиться еще 5 раз

[IgorGO]

If n > 0 Then Rows(r + 1).Resize(n).Insert:  cells(r,1).copy cells(r+1,1).resize(n,1)

[IgorGO]

Внимание!
макрос выполнить 1 раз

Achtung!
Makro ausfuhren 1 mal

Attention!
macro execute 1 times

[Aqil_f]

AleksandrH, спасибо. Макрос отлично работает. Но, 2 маленкий вопрос еще:
Как можно добaвить эти строку не столбец А, а столбец В?
А если количества строку должна быт больше 65535, тогда как?

[AleksandrH]

1. Простите, но шо сделать?
2.

lr = Cells(Rows.Count, 1).End(xlUp).Row

[IgorGO]

в столбец В

If n > 0 Then Rows(r + 1).Resize(n).Insert:  cells(r,1).copy cells(r+1,2).resize(n,1)