Code is SUPER SLOW with copying and looping merged cells

rclark

New Member
Joined
Jun 24, 2015
Messages
27
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?

Code:
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
 

Some videos you may like

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,237
Office Version
  1. 2013
Platform
  1. Windows
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
Code:
Application.screenupdating=false
at the start of the code

AND


Code:
Application.screenupdating=true

before the "End Sub line
 

rclark

New Member
Joined
Jun 24, 2015
Messages
27
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

Well-known Member
Joined
Oct 27, 2005
Messages
19,237
Office Version
  1. 2013
Platform
  1. Windows
I'd suggest an upload to Dropbox then, and share the lonk back here !!
 

Watch MrExcel Video

Forum statistics

Threads
1,108,490
Messages
5,523,251
Members
409,506
Latest member
reneekeane

This Week's Hot Topics

Top