Insert Rows according cells value in excel table

Closed
loftier Posts 1 Registration date Friday June 7, 2013 Status Member Last seen June 7, 2013 - Jun 7, 2013 at 02:39 AM
TrowaD Posts 2913 Registration date Sunday September 12, 2010 Status Moderator Last seen November 21, 2022 - Jun 10, 2013 at 11:21 AM
Dear All,

I need a Module that allowed me when I run it to add Rows down according upper cells Value for Example;

Total Names
2 Sami
5 Rami

Then after apply the Module I need like this;

Total Names
2 Sami
2 Sami
5 Rami
5 Rami
5 Rami
5 Rami
5 Rami


Then I will thank you.

1 reply

TrowaD Posts 2913 Registration date Sunday September 12, 2010 Status Moderator Last seen November 21, 2022 541
Jun 10, 2013 at 11:21 AM
Hi Loftier,

Here you go:
Sub test()
Dim x, y, cRow As Integer

cRow = 1

Do
    If Range("A" & cRow).Value > 1 Then
        x = Range("A" & cRow).Value
        y = Range("A" & cRow).Value
        Do
            Range("A" & cRow + 1).EntireRow.Insert Shift:=xlUp
            Range(Cells(cRow, "A"), Cells(cRow, "B")).Copy
            Range("A" & cRow + 1).PasteSpecial
            x = x - 1
        Loop Until x = 1
        cRow = cRow + y
    End If
Loop Until Range("A" & cRow).Value = vbNullString

Application.CutCopyMode = False

End Sub

Best regards,
Trowa
1