Need help with macro

[All2Cheesy]

I've created a Macro that will copy what's in cells and then insert that X amount of times in the cells below(Being used to copy formulas). However, the macro takes far too long to run, rendering it impractical. Could someone please assist in optimising my code so that it can run a bit quicker? Thanks in advance!

Sub AddLines()

'Enable additional feautres
With Application
        .ScreenUpdating = False
        .Calculation = Manual
        .EnableEvents = False
        .DisplayAlerts = False
End With

Dim RepeatFactor As Variant
        RepeatFactor = Cells.Range("Q7")
        
         ILoop = 1
         
         Do While ILoop <= RepeatFactor
            ActiveSheet.Range("A5023:AG5023").Copy
            ActiveSheet.Range("A5023:AG5023").Select
            Selection.Insert Shift:=xlDown
           
            ILoop = ILoop + 1
         Loop
         
    Range("A5024:G65000").Select
    Selection.ClearContents
    Range("A5024:L65000").Select
    Selection.ClearContents
    Range("A5024:Q65000").Select
    Selection.ClearContents
    
'Enable additional feautres
With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
End With

End Sub

 

[Michael M]

Try, but I'm not sure you screenupdating, enableveents OR DisplayAlerts !!!

Sub AddLines()
Application.Calculation = Manual
Range("A5023:AG5023").Copy
Range("A5023:AG5023").Resize(Range("Q7").Value).Insert Shift:=xlDown
Application.Calculation = xlAutomatic
End Sub

 

[All2Cheesy]

Try, but I'm not sure you screenupdating, enableveents OR DisplayAlerts !!!

Sub AddLines()
Application.Calculation = Manual
Range("A5023:AG5023").Copy
Range("A5023:AG5023").Resize(Range("Q7").Value).Insert Shift:=xlDown
Application.Calculation = xlAutomatic
End Sub

That's worked perfectly. Thanks for that!

 

[Michael M]

Pleasure...glad to help...