Inserting rows with VBA too slow

[HeavyGPL]

Hello, I'm using the current code to insert a row. Everything works but very slowly

Is there any form of shortening this code and accelerating ?

I wants to copy formulas and formatting from the front row during macro execution and add to the new inserted row

Sub dodaj_dodaj_wiersz()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("Tabel3")
    Dim newrow As ListRow
    Set newrow = tbl.ListRows.Add
    
    Application.Calculation = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    Dim cellleft As Single
    Dim celltop As Single
    Dim cellwidth As Single
    Dim cellheight As Single
    
    Dim shp As Shapes
    Dim shpTemp As Shape
    
    newrow.Range(1, 13).Font.Bold = True
    newrow.Range(1, 13).HorizontalAlignment = xlCenter
    newrow.Range(1, 13).VerticalAlignment = xlCenter
    newrow.Range(13) = "1"
    newrow.Range.RowHeight = 30
    
    Worksheets("Formulss").Range("A1").Copy

    newrow.Range(2).PasteSpecial Paste:=xlFormulas
    
    dodaj_dodaj_wiersz_Drku
    
    cellleft = newrow.Range(3).Left
    celltop = newrow.Range(3).Top
    

    
     Set shpTemp = ActiveSheet.Shapes.AddShape(msoShapeMathPlus, cellleft - 25, celltop + 8, 15, 15)
     shpTemp.OnAction = "'" & ActiveWorkbook.Name & "'!Add_Info"
     
     shpTemp.Fill.ForeColor.RGB = RGB(0, 0, 0)
     shpTemp.Fill.Transparency = 0.7
    
    
End Sub

 

[KOKOSEK]

Delete these 3 line with =TRUE and put instead:

At start of macro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

at end of macro

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

should speed it up a bit.

pozdrawiam

 

[dougmarkham]

Hi Heavy GPL,

I noticed you've added the following at the beginning of your code.

[/I]
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
[I]

Instead try

Sub dodaj_dodaj_wiersz()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("Tabel3")
    Dim newrow As ListRow
    Set newrow = tbl.ListRows.Add
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
    
    Dim cellleft As Single
    Dim celltop As Single
    Dim cellwidth As Single
    Dim cellheight As Single
    
    Dim shp As Shapes
    Dim shpTemp As Shape
    
    newrow.Range(1, 13).Font.Bold = True
    newrow.Range(1, 13).HorizontalAlignment = xlCenter
    newrow.Range(1, 13).VerticalAlignment = xlCenter
    newrow.Range(13) = "1"
    newrow.Range.RowHeight = 30
    
    Worksheets("Formulss").Range("A1").Copy

    newrow.Range(2).PasteSpecial Paste:=xlFormulas
    
    dodaj_dodaj_wiersz_Drku
    
    cellleft = newrow.Range(3).Left
    celltop = newrow.Range(3).Top
    

    
     Set shpTemp = ActiveSheet.Shapes.AddShape(msoShapeMathPlus, cellleft - 25, celltop + 8, 15, 15)
     shpTemp.OnAction = "'" & ActiveWorkbook.Name & "'!Add_Info"
     
     shpTemp.Fill.ForeColor.RGB = RGB(0, 0, 0)
     shpTemp.Fill.Transparency = 0.7
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
    
End Sub

In general, I prefer to create a dynamic table of my data. If then insert the formula into whole column so that any new row added automatically fills down! I insert the formula using a macro.

For instance: to create a dynamic table in excel via VBA:

Sub DynamicTables()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlManual

    Dim sht As Worksheet
    Dim rng As Range
    Dim StartCell As Range
    Dim objTable As ListObject
    
    Worksheets("Sheet1").Activate
    ActiveSheet.Range("1:1").Font.Color = vbWhite
    Set sht = Worksheets("Sheet1")
    Set StartCell = Range("A1")
    'Select Range
    StartCell.CurrentRegion.Select
    Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
    objTable.TableStyle = "TableStyleLight8"
        With ActiveSheet
        .ListObjects(1).Name = "MyTable" 'name table to suit your own needs
        .Columns.AutoFit
    End With
    
    Set rng = Range("MyTable")
    Range("MyTable").Select
    
    With rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Rows("2:2").EntireRow.Select
    ActiveWindow.FreezePanes = True
    Columns.AutoFit

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic

End Sub

This code freezes the header row so that you can see the header even if you're looking thousands of lines down.

I use named ranges rather than stipulating a range when referring to in a range within a formula. To create a named range, you use a macro such as:

Sub NameRange()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlManual
    
    Worksheets("Sheet1").Activate
    Range("MyTable[MyHeader]").Select
    ActiveWorkbook.Names.Add Name:="MyNamedRange", RefersToR1C1:= _
        "=MyTable[MyHeader]" 'no spaces in named range
    
'create a named range for every column of data you're referring to in a formula
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    
End Sub

Then you can add a formula to all cells in a column e.g.,

Sub InsertFormulaIntoColumnDynamicTable()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual

Worksheets("Sheet1").Activate
Range("MyTable[ColumnHeaderName]").Formula = _
       "=IFERROR(INDEX(DataPulling,MATCH(ThisTableMatchColumn,OtherTableMatchColumn,0)),"""")"
Columns("A:A").EntireColumn.AutoFit 'Add correct column here.

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic

In my example, I've added an INDEX MATCH formula using Named ranges. The named ranges span the whole column of the dynamic table, meaning that if you insert a row, the named range still covers any extra rows. You can record a macro to insert your formula. So long as your table is dynamic, any formula you insert using this method will automatically fill down to every cell in a column as long as no data exists to get in the way. When you insert a row, the formula should automatically be inserted into the new row.

Kind regards,

Doug.