• Ask a Question
150
Insert Image Size must be less than < 5MB.
    Ask a Question
    Cancel
    150
    More answer You can create 5 answer(s).
      Ask a Poll
      Cancel
      Expert

      Insert blank lines after every two lines from the last record

      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
      
      Asked by raghuprabhu on April 13, 2017 in VBA.
      2 Answers
      Keymaster

      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!

      Answered by PNRao on April 13, 2017..
      Expert

      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

       

      Answered by raghuprabhu on April 13, 2017..