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
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
21,274
Office Version
  1. 365
  2. 2007
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
21,274
Office Version
  1. 365
  2. 2007
Platform
  1. Windows
I'd suggest an upload to Dropbox then, and share the lonk back here !!
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,163,699
Messages
5,833,201
Members
430,196
Latest member
rez5656

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top