New rows

[Hatye]

Hi,

I have a macro to insert numerous rows, depending on content in other sheets and the macro does work. However, it is extremely slow. Therefor I wonder if anyone knows how to speed it up?

Just let me know if you need any more information!

Thank you in advance

Private Sub NyRad_Alle()


If Rapport_NyRadPunkt.TextBox1.Value = "" Then Rapport_NyRadPunkt.Hide
If Rapport_NyRadPunkt.TextBox1.Value = "" Then Exit Sub


Application.ScreenUpdating = False


AntallRaderimport = Sheets("Rapport_Import").Range("A" & Rows.Count).End(xlUp).Row
SisteRadPunktliste = Sheets("Rapport").Range("B62:B" & Rows.Count).End(xlDown).Row


AntallNyeRader = AntallRaderimport - SisteRadPunktliste + 61


    intLastFilledCellRow = Sheets("Rapport").Range("B61").End(xlDown).Row


For X = 1 To AntallNyeRader


    Sheets("Rapport").Range(intLastFilledCellRow + 1 & ":" & intLastFilledCellRow + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Sheets("Rapport").Range(intLastFilledCellRow & ":" & intLastFilledCellRow).AutoFill _
        Destination:=Sheets("Rapport").Range(intLastFilledCellRow & ":" & intLastFilledCellRow + 1), Type:=xlFillDefault
    
    With Sheets("Rapport").Range("B" & intLastFilledCellRow & ":AG" & intLastFilledCellRow).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With


Next X


Rapport_NyRadPunkt.Hide


Application.ScreenUpdating = True


End Sub

 

[Dryver14]

You seem to be copying evrything at once but then looping and doing it again try commenting out the for x = 1 to...... and the next x column.