Insert a number rows according to a cell value

[Ed Peters]

Hi all,

I am trying to insert and copy a number of rows according to a cell
value.

From the data below I would ignore all the 1's and if the number is

1, eg 4 then insert 3 rows (4-1) and copy the data, so result would

be
Londontt,4
Londontt,4
Londontt,4
Londontt,4

Orginal data below

London54 , 1
London44,1
London333,2
London77,1
London99, 5
London33,1

I can use the code below to loop.

Do Until IsEmpty(ActiveCell) = True

If ActiveCell.Value <> 1 Then
ActiveCell.EntireRow.Select
active.cell.Select
Selection.Insert
GoTo Continue
End If

ActiveCell.Offset(1, 0).Select
Loop

Continue:

Thanks,

Ed

 

[Ed Peters]

Hi all,

I am trying to insert and copy a number of rows according to a cell
value.

From the data below I would ignore all the 1's  and if the number is>1, eg 4 then insert 3 rows (4-1) and copy the data, so result would

be
Londontt,4
Londontt,4
Londontt,4
Londontt,4

Orginal data below

London54 , 1
London44,1
London333,2
London77,1
London99, 5
London33,1

I can use the code below to loop.

Do Until IsEmpty(ActiveCell) = True

If ActiveCell.Value <> 1 Then
    ActiveCell.EntireRow.Select
    active.cell.Select
     Selection.Insert
     GoTo Continue
End If

ActiveCell.Offset(1, 0).Select
 Loop

Continue:

Thanks,

Ed

Noticied my origial data did not include the one row Londontt,4

so would be

London54 , 1
London44,1
London333,2
Londontt,4
London77,1
London99, 5
London33,1

Ed

 

[Sandy Mann]

I don't really follow your request but does this do what you want:

Sub Trial()
Dim LastRow As Long
Dim x As Long
Dim I

Application.ScreenUpdating = False

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

For x = LastRow To 1 Step -1
I = Right(Cells(x, 1).Value, 1)
If IsNumeric(I) Then
If I > 1 Then
Cells(x, 1).Resize(I - 1, 1).EntireRow.Insert
End If
End If
Next x

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

For x = LastRow To 2 Step -1
If Cells(x, 1).Value = "" Then _
Cells(x, 1).Value = Cells(x + 1, 1).Value
Next x

Application.ScreenUpdating = True
End Sub

Assumes that the data starts in A1 and has no data under the data given.

Try it on a *COPY* of your data.

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

Hi all,

I am trying to insert and copy a number of rows according to a cell
value.

From the data below I would ignore all the 1's and if the number is>1, eg
4 then insert 3 rows (4-1) and copy the data, so result would

be
Londontt,4
Londontt,4
Londontt,4
Londontt,4

Orginal data below

London54 , 1
London44,1
London333,2
London77,1
London99, 5
London33,1

I can use the code below to loop.

Do Until IsEmpty(ActiveCell) = True

If ActiveCell.Value <> 1 Then
ActiveCell.EntireRow.Select
active.cell.Select
Selection.Insert
GoTo Continue
End If

ActiveCell.Offset(1, 0).Select
Loop

Continue:

Thanks,

Ed

Noticied my origial data did not include the one row Londontt,4

so would be

London54 , 1
London44,1
London333,2
Londontt,4
London77,1
London99, 5
London33,1

Ed

 

[Ed Peters]

I don't really follow your request but does this do what you want:

Sub Trial()
    Dim LastRow As Long
    Dim x As Long
    Dim I

    Application.ScreenUpdating = False

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

    For x = LastRow To 1 Step -1
        I = Right(Cells(x, 1).Value, 1)
        If IsNumeric(I) Then
            If I > 1 Then
                Cells(x, 1).Resize(I - 1, 1).EntireRow.Insert
            End If
        End If
    Next x

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

    For x = LastRow To 2 Step -1
        If Cells(x, 1).Value = "" Then _
            Cells(x, 1).Value = Cells(x + 1, 1).Value
    Next x

    Application.ScreenUpdating = True
End Sub

Assumes that the data starts in A1 and has no data under the data given.

Try it on a *COPY* of your data.

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk











Noticied my origial data did not include the one row Londontt,4

so would be

London54 , 1
London44,1
London333,2
Londontt,4
London77,1
London99, 5
London33,1

Ed- Hide quoted text -

- Show quoted text -

Yes thanks , it got me on the right direction.
Ed

 

[Sandy Mann]

I'm glad that it helped. Thanks for the feedback.

--
Regards,

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk

I don't really follow your request but does this do what you want:

Sub Trial()
Dim LastRow As Long
Dim x As Long
Dim I

Application.ScreenUpdating = False

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

For x = LastRow To 1 Step -1
I = Right(Cells(x, 1).Value, 1)
If IsNumeric(I) Then
If I > 1 Then
Cells(x, 1).Resize(I - 1, 1).EntireRow.Insert
End If
End If
Next x

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

For x = LastRow To 2 Step -1
If Cells(x, 1).Value = "" Then _
Cells(x, 1).Value = Cells(x + 1, 1).Value
Next x

Application.ScreenUpdating = True
End Sub

Assumes that the data starts in A1 and has no data under the data given.

Try it on a *COPY* of your data.

--
HTH

Sandy
In Perth, the ancient capital of Scotland
and the crowning place of kings

(e-mail address removed)
Replace @mailinator.com with @tiscali.co.uk











Noticied my origial data did not include the one row Londontt,4

so would be

London54 , 1
London44,1
London333,2
Londontt,4
London77,1
London99, 5
London33,1

Ed- Hide quoted text -

- Show quoted text -

Yes thanks , it got me on the right direction.
Ed

 

[ryguy7272]

Does this help?
Sub InsertAnyRows()

Dim insertNumber As Range
Dim insertStart As Range
Dim redRng As Range
Dim i As Integer

Set insertNumber = Application.InputBox _
(Prompt:="Select a point to begin inserting rows.
For instance, choose first non blank cell in Column A",
Title:="Add a row", Type:=8)
insertNumber.Select
If insertNumber <= 0 Then
MsgBox ("Invalid Number Entered")
Exit Sub
End If
Dim myRow As Long

lastcell = Cells(Rows.Count, "A").End(xlUp).Row
myRow = 1
Do Until myRow = lastcell
For i = 1 To Cells(myRow, 1)

If Cells(myRow, 1) <> "" Then
Cells(myRow + 1, 1).Select
Selection.EntireRow.Insert shift:=xlDown
End If

Next
lastcell = Cells(Rows.Count, "A").End(xlUp).Row
myRow = myRow + 1
Loop


End Sub


Regards,
Ryan--