Insert Rows

Can you post a dummy workbook?

Hey,

Give this workbook a try

The macro will only fire when you enter a value in the cell above the cell with the string "Total" in it on sheet 1.

Sub d()
 
 Dim ws As Worksheet, wsM As Worksheet
 Dim i&, LR&
 Dim cel As Double
   
   Set ws = Sheets("Sheet2")
   Set wsM = Sheets("Sheet1")
   LR = wsM.Cells(wsM.Rows.Count, 1).End(xlUp).Row
       wsM.Rows(LR).EntireRow.Insert
       ws.Rows(LR).EntireRow.Insert
            For i = 3 To 6
             cel = wsM.Application.Sum(Range(Cells(4, i), Cells(LR, i)))
              wsM.Cells(LR + 1, i).Value = cel
            Next i
       wsM.Cells(LR, 6).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
       ws.Cells(LR, 6).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
        cel = 0
         For i = 1 To 5
          cel = ws.Application.Sum(Range(Cells(4, i), Cells(LR, i)))
            ws.Cells(LR, i).FormulaR1C1 = "=Sheet1!RC"
             If i >= 3 Then
               ws.Cells(LR + 1, i).Value = cel
             End If
         Next i
   
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Dim LR&, cel As Range
   LR = Cells(Rows.Count, 1).End(xlUp).Row
   Set cel = Cells(LR - 1, 1)
    If Not Intersect(Target, cel) Is Nothing Then
       Call d
    End If
End Sub

Hey ,
Try this, again the cell above the total cell will fire the macro.

Sub d()
 
 Dim ws As Worksheet, wsM As Worksheet
 Dim i&, LR&
 Dim cel As Double
   
   Set ws = Sheets("Sheet2")
   Set wsM = Sheets("Sheet1")
   LR = wsM.Cells(wsM.Rows.Count, 1).End(xlUp).Row
       wsM.Rows(LR).Resize(100).EntireRow.Insert
       ws.Rows(LR).Resize(100).EntireRow.Insert
            For i = 3 To 6
             cel = wsM.Application.Sum(Range(Cells(4, i), Cells(LR, i)))
              wsM.Cells(LR + 1, i).Value = cel
            Next i
       wsM.Cells(LR, 6).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
       ws.Cells(LR, 6).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
        cel = 0
         For i = 1 To 5
          cel = ws.Application.Sum(Range(Cells(4, i), Cells(LR, i)))
            ws.Cells(LR, i).FormulaR1C1 = "=Sheet1!RC"
             If i >= 3 Then
               ws.Cells(LR + 1, i).Value = cel
             End If
         Next i
   
End Sub

Can you attach the workbook with the new layout?

What columns in sheet 2 do you want formulas input into?

Columns A to Column AF in Sheet 2

OK,

The code is done. I need emphasize that the format or layout can not be changed or the Macro will cease to work.

When there is less than 100 rows in column A the macro will fire and insert 100 extra rows and so on and so forth.

Sub d()
 
 Dim ws As Worksheet, wsM As Worksheet
 Dim i&, LR&, LC&, rng As Range, cel2 As Range
 Dim cel As Variant, cADD As Variant, bRng As Range
 
 
 Application.ScreenUpdating = 0
   Set ws = Sheets("Sheet2")
   Set wsM = Sheets("Sheet1")
   
   LR = wsM.Cells(wsM.Rows.Count, 1).End(xlUp).Row
   LC = wsM.Cells(12, wsM.Columns.Count).End(xlToLeft).Column
   
   
   Set rng = wsM.Range(Cells(15, 6), Cells(16, LC))
       wsM.Rows(LR).Resize(100).EntireRow.Insert
       ws.Rows(LR).Resize(100).EntireRow.Insert
     With wsM
           For Each cel In rng
                If cel = "Y/N" Then
                    cADD = cel.Address
                     .Range(cADD).Offset(1).Resize(84 + LR).FormulaR1C1 = "=IF(RC3="""","""",IF(RC4=2011,""Yes"",IF(AND(RC4=2012,OR(RC5=""Na"",RC5=""Jan"",RC5=""Feb"",RC5=""Mar"")),""Yes"",""No"")))"
                     .Range(cADD).Offset(1, 1).Resize(84 + LR).FormulaR1C1 = "=SUM(RC[-7]:RC[-2])"
               
                ElseIf cel = "Qtr 4" Then
                  cADD = cel.Address
                   Set cel2 = .Range(cADD).Offset(1)
                   If cel2 = "Y/N" Then
                     cADD = cel2.Address
                      .Range(cADD).Offset(1).Resize(84 + LR).FormulaR1C1 = "=IF(RC3="""","""",IF(RC4=2011,""Yes"",IF(AND(RC4=2012,OR(RC5=""Na"",RC5=""Jan"",RC5=""Feb"",RC5=""Mar"")),""Yes"",""No"")))"
                      .Range(cADD).Offset(1, 1).Resize(84 + LR).FormulaR1C1 = "=SUM(RC[-7]:RC[-2])"
                      .Range(cADD).Offset(1, 2).Resize(84 + LR).FormulaR1C1 = "=IF(AND(RC12=""Yes"",RC20=""Yes"",RC28=""Yes"",RC36=""Yes""),""Yes"",""No"")"
                      .Range(cADD).Offset(2, 3).Resize(84 + LR).FormulaR1C1 = "=RC[-26]+RC[-18]+RC[-10]+RC[-2]"
                  End If
                End If
           Next cel
              Border .Range(Cells(17, 1), Cells(LR + 99, 39))
              Border .Range(Cells(17, 42), Cells(LR + 99, 75))
              Border .Range(Cells(17, 78), Cells(LR + 99, 111))
              Border .Range(Cells(17, 114), Cells(LR + 99, 147))
        End With
              
         ws.Activate
      With ActiveSheet
        LC = .Cells(15, .Columns.Count).End(xlToLeft).Column
        
            .Range("A17:AF17").Copy
          For i = 17 To LR + 99
             .Range("A" & i).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
          Next i
            
            Border .Range(Cells(17, 1), Cells(LR + 99, 5))
            Border .Range(Cells(17, 7), Cells(LR + 99, 12))
            Border .Range(Cells(17, 15), Cells(LR + 99, 20))
            Border .Range(Cells(17, 23), Cells(LR + 99, 32))
             
            .Cells(LR + 100, 4).FormulaR1C1 = "=COUNTIF( R[" & -LR - 83 & "]C:R[-1]C,""Yes"")"
            .Cells(LR + 100, 9).Resize(, 4).FormulaR1C1 = "=COUNT(R[" & -LR - 83 & "]C:R[-1]C)"
            .Cells(LR + 100, 19).Resize(, 2).FormulaR1C1 = "=COUNT(R[" & -LR - 83 & "]C:R[-1]C)"
      End With
        
        wsM.Activate
        
   Application.ScreenUpdating = 1
End Sub
Sub Border(rng As Range)
     
    With rng
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            .Color = 16764057
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            .Color = 16764057
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            .Color = 16764057
        End With
    End With
     
End Sub

This code fires the Macro above,

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim LR&, cel&
    LR = Cells(Rows.Count, 1).End(xlUp).Row
  
   If Intersect(ActiveCell, Range("A17:A" & LR)) Is Nothing Then
       cel = Application.WorksheetFunction.CountBlank(Range("A17:A" & LR))
        If cel < 100 Then
          Call d
      End If
    End If
       
End Sub

Thank you very much Dave. Appreciate your efforts. Many Thanks