Excel VBA - Copy Data to Blank Rows After Blanks Rows Inserted Between Data?

[MEUserII]

I am looking to see if anyone might have a macro for data that has blank rows inserted between data?

For example beginning with this:

	Column_A	Column_B	Column_C	Column_D	Colum_E
Row_1	ALPHA	APPLE	ABC
Row_2	BETA	ORANGE	DEF
Row_3	GAMMA	KIWI	GHI
Row_4	DELTA	COCONUT	JKL
Row_5	ECHO	LIME	MNO
Row_6	FRANK	LEMO	PQR

<tbody>
</tbody>

I use the following insert blank rows macro to insert three blank rows:

Sub INSERTBLANKROWS()


Dim j As Long
Dim r As Range


j = InputBox("Enter the number of rows to be inserted")

Set r = Range("A1")
Do While r.Value <> ""
    Set r = r.Offset(1, 0)
    For i = 1 To j
        r.EntireRow.Insert
    Next
Loop


End Sub

And now need to copy the data from each "data row" to the blank rows inserted to end up with the following:

	Column_A	Column_B	Column_C	Column_D	Colum_E
Row_1	ALPHA	APPLE	ABC
Row_2	ALPHA	APPLE	ABC
Row_3	ALPHA	APPLE	ABC
Row_4	ALPHA	APPLE	ABC
Row_5	BETA	ORANGE	DEF
Row_6	BETA	ORANGE	DEF
Row_7	BETA	ORANGE	DEF
Row_8	BETA	ORANGE	DEF

<tbody>
</tbody>

What macro would I use to be able to do this?

 

[Rick Rothstein]

Give this macro a try...

[table="width: 500"]
[tr]
	[td]Sub AddFillThreeRows()
  Dim R As Long, LR As Long, LC As Long, HowManyRows As Long
  Application.ScreenUpdating = False
  ' Insert Rows
  HowManyRows = Application.InputBox("Enter the number of rows to be inserted:", Type:=1)
  If Len(HowManyRows) Then
    For R = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
      Rows(R).Resize(HowManyRows).Insert
    Next
    ' Fill Empty Cells
    LR = Cells(Rows.Count, "A").End(xlUp).Row + HowManyRows
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    With Range("A1", Cells(LR, LC))
      .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
      .Value = .Value
    End With
  End If
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

 

[MEUserII]

Give this macro a try...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub AddFillThreeRows()
  Dim R As Long, LR As Long, LC As Long, HowManyRows As Long
  Application.ScreenUpdating = False
  ' Insert Rows
  HowManyRows = Application.InputBox("Enter the number of rows to be inserted:", Type:=1)
  If Len(HowManyRows) Then
    For R = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
      Rows(R).Resize(HowManyRows).Insert
    Next
    ' Fill Empty Cells
    LR = Cells(Rows.Count, "A").End(xlUp).Row + HowManyRows
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    With Range("A1", Cells(LR, LC))
      .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
      .Value = .Value
    End With
  End If
  Application.ScreenUpdating = True
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Thanks for the reply although this code did not seem to work all that well for me. I actually ended it up figuring out my own solution to this problem, and have posted my code below:

Sub copyRowToBelow() 

    Dim rng As Range
    Set rng = Range("A1") ' <~~  Change this

    Do While (rng.Row < 461) 'This value represents total number of rows after first macro created blank rows, so it serves as the upper limit.
        ' Insert a row below the current one
        'rng.Offset(1).Insert

        ' Copy the current row and paste it into the row we just inserted

rng.EntireRow.Copy rng.Offset(1)
rng.EntireRow.Copy rng.Offset(2)

        ' Set the range declaration for 3 rows below the current one
        Set rng = rng.Offset(3)
        
    Loop
   
End Sub

The only thing I am stuck on now is along with the first code that references the input: "j = InputBox("Enter the number of rows to be inserted")"; how to the adjust the code I listed above to dynamically work with the same input, "j". In other words, If "j = 6" is inputted in the first portion of code; then how to update the code listed above to use that same input "j" and copy the data to the same number "j" blanks rows inserted?