Is there an easier way to repeatedly insert lines to the bottom of the list?

Question

I am trying to add a line to the bottom of a list by clicking a button (Excel VBA). Is this the easiest way to do it? If it is, this code is not working, it stops after selecting "B37". Any advice will be helpful. Thanks!!

Subject 1: xxxxx -- Subject 1: xxxxx -- Subject 1: xxxxx
Subject 2: xxxxx -- Subject 2: xxxxx -- Subject 2: xxxxx
Subject 3: xxxxx to Subject 3: xxxxx to Subject 3: xxxxx
Subject 4: xxxxx -- .................xxxxx -- .................xxxxx
Subject 5: xxxxx -- Subject 4: xxxxx -- .................xxxxx
..............................Subject 5: xxxxx -- Subject 4: xxxxx
............................................................Subject 5: xxxxx

 Sub ReferenceDocAddiditon() ' ' ReferenceDocAddiditon Macro ' ' ' Range("B37").Select If ActiveCell = "" Then Range("B38").Select If ActiveCell = "" Then Range("B39").Select If ActiveCell = "" Then Range("B40").Select If ActiveCell = "" Then Range("B41").Select If ActiveCell = "" Then Range("B42").Select If ActiveCell = "" Then Range("B43").Select If ActiveCell = "" Then Range("B44").Select If ActiveCell = "" Then Range("B45").Select If ActiveCell = "" Then Range("B46").Select If ActiveCell = "" Then ElseIf ActiveCell <> "" Then Rows("45:45").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B44").Select ElseIf ActiveCell <> "" Then Rows("44:44").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B43").Select ElseIf ActiveCell <> "" Then Rows("43:43").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B42").Select ElseIf ActiveCell <> "" Then Rows("42:42").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B41").Select ElseIf ActiveCell <> "" Then Rows("41:41").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B40").Select ElseIf ActiveCell <> "" Then Rows("40:40").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B39").Select ElseIf ActiveCell <> "" Then Rows("39:39").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B38").Select ElseIf ActiveCell <> "" Then Rows("38:38").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B37").Select ElseIf ActiveCell <> "1" Then Rows("37:37").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("B36").Select ElseIf ActiveCell <> "" Then Rows("35:37").Select Selection.EntireRow.Hidden = False End If End If End If End If End If End If End If End If End If End If 

Answer 1

I can't speak for everything you are trying to do, but I can tell you what this will do.

Without having to select any cells, except at the end of the macro to return control to Column A of the new row, just inserted, leaving any formatting.

There's probably an easier way to do this, but my brain works like this. Feel free to look for other solutions or adapt this to suit your needs if it's not just right. Comments in the code should provide insight as to what's going on.

TESTED: see pics

Sub InsertRowAtEnd()

Dim lastRow As Long   
Dim lastCol As Long   
Dim sheet As String

    sheet = "Sheet1"    'Name your sheet here.
    lastRow = Sheets(sheet).Range("A" & Rows.Count).End(xlUp).row          'Get last Row & col
    lastCol = Sheets(sheet).Cells(2, Columns.Count).End(xlToLeft).Column

    Sheets(sheet).Cells(lastRow, 1).EntireRow.Insert    'Insert a new row before the last row

    For lCol = 1 To lastCol                             'Copy the last row to the inserted row
        Sheets(sheet).Cells(lastRow, lCol) = Sheets(sheet).Cells(lastRow + 1, lCol)
        Sheets(sheet).Cells(lastRow + 1, lCol).ClearContents    'erase the old last row
    Next lCol

    Sheets(sheet).Cells(lastRow + 1, 1).Select           'Return focus to the new cell A(row)

End Sub