VBA Shift Rows Within Range - Execution Speed

I have two worksheets with ranges, one is 452 rows by 11 columns and the other is 152 rows by 28 columns. The ranges are not only filled with data but make heavy usage of conditional formatting.

Each day, I need to shift all of the rows down one row. Doing a copy/paste of the entire range less the first row blows up on memory usage.

I wrote the following VBA routine to handle the shift one row at a time ... this one handles the 452x11. It does the job but takes 20 seconds on the 452x11 range and same routine takes 40 seconds on the 152x28 range.

  Dim iRangeRowX As Integer
  Dim iRangeRowsInRange As Integer
  Dim iRangeBeginsRow As Integer
  Dim iRangeEndsRow As Integer
  Dim rRange As Range
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Worksheets("BreadthModels").Activate
  Set rRange = Worksheets("BreadthModels").Range("BreadthModelTable")
  With rRange
    iRangeRowsInRange = .Rows.Count  ' row count for this range
    iRangeBeginsRow = .Row     ' first row for this range
    iRangeEndsRow = (iRangeBeginsRow + iRangeRowsInRange) - 1
    ' columns are hard coded
    For iRangeRowX = (iRangeBeginsRow + 2) To (iRangeEndsRow - 1) Step 1
      Range("E" & iRangeRowX & ":P" & iRangeRowX).Select
      Application.CutCopyMode = False
      Selection.Copy
      Range("E" & iRangeRowX - 1 & ":P" & iRangeRowX - 1).Select
      ActiveSheet.Paste
      DoEvents  'allow break
    Next
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Calculate

Is there anything which can be done to speed execution? Thank you.

Earl

Couldn't you just right click on the row number and select Insert?

Application does not allow that. The rows must be copied and pasted to preserve external references. Changing the external references to Offset creates other performance problems. Objective is to speed the code performance of the project as designed.

Can you post a sample workbook?

Not tested, but this may work...

Public Sub SpeedUp()
    Dim vB As Variant
    Dim x As Long
    Dim y As Integer
    vB = Range("BreadthModelTable")
    For x = LBound(vB, 1) + 2 To UBound(vB, 1) - 1
        For y = LBound(vB, 2) To UBound(vB, 2)
           vB(x - 1, y) = vB(x, y)
        Next y
    Next x
    Range("BreadthModelTable") = vB
End Sub

Thank you for all the suggestions but none do the trick.

a) I lose all formatting when I transfer the cells into an array and back

b) Hadn't used Application.EnableEvents previously but thought it worth a try if it would suppress the changing of external references. It did not.

I have developed tighter code than what I originally posted by using ".Copy Destination:=" (see below) however that shaved a surprisingly small 5% off execution time compared to the Select/Copy/Paste I had used previously. (Replacing the second .Range reference with .Cells((.Rows.Count - 2),"A") did nothing for speed so I retained .Range for consistency.)

Routine below shows the new syntax along with the use of Application.EnableEvents:

Sub TestShift()
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set rRange = Worksheets("Sheet1").Range("TestRange")
  With rRange
    .Rows(.Rows.Count - 1).Insert
    .Rows(2).Delete
    .Range("A" & (.Rows.Count - 1) & ":D" & (.Rows.Count - 1)).Copy Destination:=.Range("A" & (.Rows.Count - 2))
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Calculate
End Sub

This did everything I wanted in about 1/3 the time except that the external reference was messed up for the first line of data.

This image shows what I am doing and what happened:

UL: TestRange (bounded by the heavy border) after insert/delete/copy completed with invalid external reference to immediate right
LL: View of TestRange before editing with original external reference to immediate right
UR: View of what I intend TestRange to look like after editing with external references to immediate right

As can be seen, the external reference for the first row was lost. This would work if there was some way of preventing the external referenced from being changed when the update takes place.

EF-Shift.jpg

So far, the only way I've found to preserve the external references and preserve the formatting included in the working sheet, is to use copy Destination:=.

Earl

It had not occurred to me that I could separate the data/formulas and the formatting so I tried the posted example. The copy/paste through the array was instantaneous. Unfortunately, any insertion or deletion of rows causes problems for the external references.

With the instantaneous copy/paste via the array, I attacked the problem of copying the formatting:

  Dim rRange As Range
  Dim rCopy As Range
  Dim rPaste As Range
  Dim arrvarXfer As Variant

  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Worksheets("BreadthModels").Activate
  Set rRange = Worksheets("BreadthModels").Range("BreadthModelTable")
  With rRange
      ' copy range: exclude top 2 and bottom 1 rows
      Set rCopy = .Offset(2, 4).Resize(.Rows.Count - 3, (.Columns.Count - 4))
      ' paste range: to top 1 - bottom 2 rows unchanged
      Set rPaste = .Offset(1, 4).Resize(.Rows.Count - 3, (.Columns.Count - 4))
      arrvarXfer = rCopy.Formula
      rPaste.Cells = arrvarXfer
      rCopy.Select
      rCopy.Copy
      rPaste.PasteSpecial xlPasteFormats
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Calculate
End Sub

The good news was that while a complete (data and format) copy paste failed due to excessive memory use, the copy paste of the formatting did complete. The bad news is that it took twice as long as the optimized code Copy Destination:= code I posted on the 18th.

a) Is there a way to keep the external references from updating the reference points during and following a VBA insert/delete?

b) Does PasteSpecial create an undo stack which might being slowing down the format copy/paste?

Lack of sleep...? :> ? Thanks for the reminder!

Reason for using the array variable is that it provides intermediate storage. Memory craps out when doing anything equivalent to a bulk copy/paste ... this appears to be entirely due to Excel's Undo stack for which I can find no "off" switch. Turning off screen updating, calculation, and events does not do it.

I need to carry cell formatting and working through an array does not carry the formatting. Also need to preserve external references which precludes use of insert/delete.

So far, the fastest method is iterating copy/paste row by row. I coded a test where I copy/pasted blocks of 10 rows at a time until I got within 10 rows of the end and it ran slower than the row by row.

Since a manual block copy/paste of all rows ran into Undo memory issues, I thought that might be the case with VB however in researching that issue, I found the following in the MS KB: "When you run a Visual Basic for Applications macro, Excel allocates no memory for undoing actions. This feature is disabled for optimization of performance when you run a macro." So I have no clue as to why copy/paste in blocks of 10 rows runs much slower than row by row.

This is what I have which is working: does not crap out on memory, retains formatting, and preserves external references:

Sub ShiftTables()
  ' ------------------------------------------------------------------------------
  ' Usage: call ShiftTables
  '
  ' Shifts the Breadth Models and the HGSI Data Tables one row
  '   Copy/paste exceeds memory
  '   60 seconds execution time
  ' Fully optimized (Destination:=.Cells(r,c) no faster than .Range(c,r)
  ' ------------------------------------------------------------------------------
  Dim iRangeRowX As Integer
  Dim iRangeTopRow As Integer
  Dim rRange As Range

  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set rRange = Worksheets("BreadthModels").Range("BreadthModelTable")
  With rRange
    iRangeTopRow = .Rows.Count - 1
    For iRangeRowX = 3 To iRangeTopRow Step 1
      .Range("E" & iRangeRowX & ":P" & iRangeRowX).Copy Destination:=.Range("E" & (iRangeRowX - 1))
      DoEvents  'allow break
    Next
  End With
  Set rRange = Worksheets("HGSI Data").Range("HgsiDataTable")
  With rRange
    iRangeTopRow = .Rows.Count - 1
    For iRangeRowX = 3 To iRangeTopRow Step 1
      .Range("D" & iRangeRowX & ":AD" & iRangeRowX).Copy Destination:=.Range("D" & (iRangeRowX - 1))
      DoEvents  'allow break
    Next
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Calculate
End Sub