Previous Topic Next Topic

Insert Rows according cells value in excel table

Closed
loftier Posts 1 Registration date Friday 7 June 2013 Status Member Last seen 7 June 2013 - 7 Jun 2013 à 02:39
TrowaD Posts 2921 Registration date Sunday 12 September 2010 Status Contributor Last seen 27 December 2022 - 10 Jun 2013 à 11:21
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 response

Réponse 1 / 1
TrowaD Posts 2921 Registration date Sunday 12 September 2010 Status Contributor Last seen 27 December 2022 555
10 Jun 2013 à 11:21
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