Insert blank lines after every two lines from the last record

Answered

I have one line of heading and 46 lines of data. I want to insert a blank line between two records starting from the bottom

This is just testing…I may have 6000+ lines of data and so I want to automate it.

If someone could show me how to do it in a shorter way.

 

Regards

 

Raghu

 

Sub InsertBlankRowsFromBottom()
ActiveWorkbook.Worksheets("Matched").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Matched").Sort.SortFields.Add Key:=Range("A2:A47") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Matched").Sort
.SetRange Range("A1:B47")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.End(xlDown).Select
Rows("46:46").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("44:44").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("42:42").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("40:40").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("38:38").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("36:36").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("34:34").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("32:32").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("30:30").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("28:28").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("26:26").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("24:24").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("22:22").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("20:20").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("18:18").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("16:16").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("14:14").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("12:12").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("10:10").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("8:8").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("6:6").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("4:4").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveWorkbook.Save
End Sub
Top Contributor Asked on April 13, 2017 in VBA.
Add Comment
2 Answer(s)
Best answer

Hi, Here is the VBA code to insert blank rows/records every at alternative row from bottom.

Sub VBAF1_InsertBlankRows()
intStartRow = 2 'Since the Row 1 have headers
intLastRow = 46 'You can change if requred
For iCntr = intLastRow To intStartRow Step -1
Rows(iCntr).EntireRow.Insert
Next
End Sub

Thanks!

Keymaster Answered on April 13, 2017.
Add Comment

PNRao Garu,

Thank you for your response…

I modified it as follows and it is working and doing what I want…

Sub VBAF1_InsertBlankRows()
intStartRow = 2 'Since the Row 1 have headers
intLastRow = Sheets("Matched").Cells(Sheets("Matched").Rows.Count, "A").End(xlUp).Row - 1
For iCntr = intLastRow To intStartRow Step -2
Rows(iCntr).EntireRow.Insert
Next
End Sub

Regards

 

Top Contributor Answered on April 13, 2017.
Add Comment
  • Found this useful?

    Please share using the share button above.

    If you found the answer is best answer for your question, Please mark as 'best answer' by clicking on the right tick mark icon at the left side of the answer.

    Found the answer useful and wants to credit the user, then vote the answer (vote up).

  • Your Answer

    By posting your answer, you agree to the privacy policy and terms of service.