copy and insert entire row based on integer in column A

[Dave A]

Hello,

I have a spreadsheet that contains data as follows;

3 rgf rhh
2 xyz abc
4 ejerr
5 rrrr

I would like a macro that copies and inserts the entire row "x" times,
based on the value of the number in column A.

The file can be thousands of lines long.
Maximum number in column a is 50


desired result

3 rgf rhh
3 rgf rhh
3 rgf rhh
2 xyz abc
2 xyz abc
4 ejerr
4 ejerr
4 ejerr
4 ejerr
5 rrrr
5 rrrr
5 rrrr
5 rrrr
5 rrrr

Thanks
Dave

 

[Norman Jones]

Hi Dave,

Try:

'=============>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range
Dim i As Long, k As Long
Dim LRow As Long

Set WB = Workbooks("YourBook.xls") '<<==== CHANGE
Set SH = WB.Sheets("Sheet1") '<<==== CHANGE

LRow = SH.Cells(Rows.Count, "A").End(xlUp).Row

For i = LRow To 1 Step -1
With SH.Cells(i, "A")
k = .Value - 1
If k > 0 Then
.EntireRow.Resize(k).Insert
.Offset(-1, 1).Resize(k).Value = _
.Offset(0, 1).Value
.Offset(-1).Resize(k).Value = .Value
End If
End With
Next i

End Sub
'<<=============

 

[Dave A]

Hi Dave,

Try:

'=============>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range
Dim i As Long, k As Long
Dim LRow As Long

Set WB = Workbooks("YourBook.xls") '<<==== CHANGE
Set SH = WB.Sheets("Sheet1") '<<==== CHANGE

LRow = SH.Cells(Rows.Count, "A").End(xlUp).Row

For i = LRow To 1 Step -1
With SH.Cells(i, "A")
k = .Value - 1
If k > 0 Then
.EntireRow.Resize(k).Insert
.Offset(-1, 1).Resize(k).Value = _
.Offset(0, 1).Value
.Offset(-1).Resize(k).Value = .Value
End If
End With
Next i

End Sub
'<<=============

Thanks Norman.
Didn't work as I expected.
I suspect that the rows are being overwritten as this programme results
in black rows in between the expected data.

 

[Norman Jones]

Hi Dave,

Didn't work as I expected.
I suspect that the rows are being overwritten as this programme results
in black rows in between the expected data.

Try this minor amendment:

'=============>>
Public Sub TesterX()
Dim WB As Workbook
Dim SH As Worksheet
Dim rng As Range
Dim i As Long, k As Long
Dim LRow As Long

Set WB = Workbooks("YourBook.xls") '<<==== CHANGE
Set SH = WB.Sheets("Sheet1") '<<==== CHANGE

LRow = SH.Cells(Rows.Count, "A").End(xlUp).Row

For i = LRow To 1 Step -1
With SH.Cells(i, "A")
k = .Value - 1
If k > 0 Then
.EntireRow.Resize(k).Insert
.Offset(-k, 1).Resize(k).Value = _
.Offset(0, 1).Value
.Offset(-k).Resize(k).Value = .Value
End If
End With
Next i

End Sub
'<<=============

 

[Dave A]

FYI
I found another script in this newsgroup which fundamently does what I
want.
exept it copies N+1 times instead of N. I can overide this with a crude
edit before I run the macro until I work out a better way.

Sub AddRows()
Dim i As Long, AdditionalRows As Long, NextRow As Long
Dim Cel As Range


For Each Cel In ActiveSheet.Range("A1").EntireColumn.Cells
If Cel.Value = "" Then
Exit For
Else
If IsNumeric(Cel.Value) Then
AdditionalRows = AdditionalRows + CLng(Cel.Value) + 3
End If
End If
Next Cel


If ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row +
AdditionalRows < 65537 Then
For Each Cel In ActiveSheet.Range("A1").EntireColumn.Cells
If NextRow > 0 Then
NextRow = NextRow - 1
GoTo NextCel
End If


NextRow = 0
If Cel.Value <> "" And IsNumeric(Cel.Value) Then
For i = 1 To CLng(Cel.Value)
Cel.Offset(1, 0).EntireRow.Insert
Cel.EntireRow.Copy Cel.Offset(1, 0)
Next i
NextRow = NextRow + i - 1
End If
NextCel:
Next Cel
Else
End

 

[Dave A]

Norman,

worked well.
There's only one minor problem.
The output has each row N+1 times based on the number in the first
column.
Since we have an "original" we only need to copy N-1 times.


Thanks again
Dave

 

[Norman Jones]

Hi Dave,

I found another script in this newsgroup which fundamently does what I
want.
exept it copies N+1 times instead of N. I can overide this with a crude
edit before I run the macro until I work out a better way.

Did you try the revised code that I posted?

 

[Dave A]

Did you try the revised code that I posted?

Yup. I missed your reply before I reposted.

Code works well, expect as commented above.
Each row copied once two many times as the orginal is retained.

Regards
Dave

 

[Norman Jones]

Hi Dave,

There's only one minor problem.
The output has each row N+1 times based on the number in the first
column.

Your original post showed your raw data as:

3 rgf rhh
2 xyz abc
4 ejerr
5 rrrr


You showed the required resuks as:

3 rgf rhh
3 rgf rhh
3 rgf rhh
2 xyz abc
2 xyz abc
4 ejerr
4 ejerr
4 ejerr
4 ejerr
5 rrrr
5 rrrr
5 rrrr
5 rrrr
5 rrrr


Which is what my suggested code produces - indeed the above table is a
direct copy / paste of the data produced by the code.

Since we have an "original" we only need to copy N-1 times.

This requirement is reflected in the lines:

k = .Value - 1
If k > 0 Then
.EntireRow.Resize(k).Insert

k is the value in column A, k-1 rows are inserted.

If you are stll experiencing a problem, I can send you my test book in
response to an email:

norman_jones@NOSPAMbtconnectDOTcom

(Delete "NOSPAM" and replace "DOT" with a full stop [period] )