Code is SUPER SLOW with copying and looping merged cells

[rclark]

I have some code going through 20 rows and 4 columns copying and clearing each line from a selected point to "insert" a row without actually inserting. I can't actually insert the row and I'm working in merged cells. I'm also moving images in a specific column but that doesn't seem to be the problem. The code works BUT it's clunky and slow. Can someone take a look and point me towards a method to speed this up?

Sub InsertLine()
    Application.Run "Module1.SetGlobals"[COLOR=#0000ff] ' This is a sub that defines common public variables these variables are blue throughout the code[/COLOR]
[COLOR=#008000]    ' If last cell in range has content no insert allowed[/COLOR]
        If [COLOR=#0000ff]rWorkSeq[/COLOR].Cells([COLOR=#0000ff]rWorkSeq[/COLOR].Rows.Count, 1).Value <> "" Then
            MsgBox "Insert not possible if last line has content"
            Exit Sub
        End If
[COLOR=#008000]    ' Declarations[/COLOR]
        Dim sh As Shape
        Dim RangeRows As Integer
        Dim RangeStart As Integer
        Dim RangeEnd As Integer
        Dim SelectedRow As Integer
        Dim SelectedRowTop As Integer
        Dim WorkSeqCol As Integer
        Dim SeqCol As Integer
        Dim KeyPointsCol As Integer
        Dim TimeCol As Integer
[COLOR=#008000]    ' Variable Definitions[/COLOR]
        WorkSeqCol = [COLOR=#0000ff]rWorkSeq[/COLOR].Column
        SeqCol = [COLOR=#0000ff]rSeq[/COLOR].Column
        KeyPointsCol = [COLOR=#0000ff]rKeyPoints[/COLOR].Column
        TimeCol = [COLOR=#0000ff]rTime[/COLOR].Column
        RangeRows = [COLOR=#0000ff]rWorkSeq[/COLOR].Rows.Count
        RangeStart = [COLOR=#0000ff]rWorkSeq[/COLOR].Row
        RangeEnd = [COLOR=#0000ff]rWorkSeq[/COLOR].Row +[COLOR=#0000ff] rWorkSeq[/COLOR].Rows.Count - 1
        SelectedRow = Selection.Row
        SelectedRowTop = Selection.Top
[COLOR=#008000]    ' Call WB prep[/COLOR]
        Application.Run "Module1.HandleBeforeChanges"
[COLOR=#008000]    ' Come back to sheet[/COLOR]
        [COLOR=#0000ff]sSht[/COLOR].Select
[COLOR=#008000]    ' Loop through rows in WorkSeq and shift everything down from selected row[/COLOR]
        For i = 0 To RangeRows - 1
            If RangeEnd - i > SelectedRow Then
                Cells(RangeEnd - i, WorkSeqCol).Value = Cells(RangeEnd - i - 1, WorkSeqCol).Value
                Cells(RangeEnd - i - 1, WorkSeqCol).Value = ""
                Cells(RangeEnd - i, KeyPointsCol).Value = Cells(RangeEnd - i - 1, KeyPointsCol).Value
                Cells(RangeEnd - i - 1, KeyPointsCol).Value = ""
                Cells(RangeEnd - i, TimeCol).Value = Cells(RangeEnd - i - 1, TimeCol).Value
                Cells(RangeEnd - i - 1, TimeCol).Value = ""
            End If
        Next i
[COLOR=#008000]    ' Shift Images down if on or below selected row[/COLOR]
        For Each sh In [COLOR=#0000ff]sSht[/COLOR].Shapes
            If sh.Top >= SelectedRowTop And sh.Left >= Columns(SeqCol).Left And sh.Left < Columns(SeqCol + 1).Left Then
                sh.Top = sh.Top + 45
            End If
        Next sh
[COLOR=#008000]    ' prep WB for user[/COLOR]
    Application.Run "Module1.HandleAfterChanges"
End Sub

 

[Michael M]

change your code to work from the bottom up in the loop, NOT from the top down.
That way only 1 row is moved at a time, NOT the entire block of data
Also...put

Application.screenupdating=false

at the start of the code

AND

Application.screenupdating=true

before the "End Sub line

 

[rclark]

Thank you for the response though these are already happening in the code The loop is working from the bottom up as I am subtracting i from the end of the list. Also, the Application.Screen updating is in the macro being called to prep the file though I did not share that code. The prep sub turns off screen updating, unprotects the sheets and workbook, and unhides some sheets.

[/CODE]

 

[Michael M]

I'd suggest an upload to Dropbox then, and share the lonk back here !!