How Can I Improve The Efficiency of my Loop For a Large Application

Question

I have created a large VBA program to automate creation of a data table that is needed to run slicers in an Excel file. While the loop works well in creating what I need. The main loop take an hour to create the list of company names that I need. I was wondering if there is a way to improve the time it takes for the loop to complete. I have 191 rows that need to be copied and then pasted 68 times each into the new sheet. I have tried a few different approaches to improve the time and have only reduced the time required to about 50 minutes. Any help would be much appreciated. I know that using select is horrible for time efficiency but all the other options I have tried have not worked well.

Dim rng As Range, cell As Range
For Each cell In rng

    Sheets("Input Data").Select
    cell.Select
    cell.Copy
    Sheets("TrialSheet").Select
    For i = 1 To 68
        LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Range("A" & LastRow).Select
        ActiveSheet.Paste
    Next i

    Sheets("Input Data").Select

Next cell

You would have better luck on codereview for optimization questions. However, If you get rid of the copy and paste and just dump the values directly it will significantly reduce the runtime. — Warcupine, Jul 03 '19 at 12:17
To begin with, do `application.ScreenUpdating = False ` before the loop and `application.ScreenUpdating = True` after the loop ends. — shahkalpesh, Jul 03 '19 at 12:20
I forgot to add that into the code, it is there. That saved about 5 min. — MULaker, Jul 03 '19 at 12:23
Also read this https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba And you can do the pasting in one go without a loop or better still follow @Warcupine's suggestion. — SJR, Jul 03 '19 at 12:38

Dávid Laczkó · Answer 1 · 2019-07-03T12:50:56.613

0

Please remove the last Sheets("Input Data").Select - that is unnecessary, as the loop begins with that.
Secondly, the internal for loop can be replaced with this operation that fills a range in batch:

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow & ":A" & LastRow + 68).PasteSpecial

I think it should be faster, but further adjustments might be necessary.

edited Jul 03 '19 at 12:50

answered Jul 03 '19 at 12:44

Dávid Laczkó

1,091
2
6
25

score 0 · Answer 2 · answered Jul 03 '19 at 12:45

Instead of copying and pasting cells, read them once into memory into a 2-dimensional array and write the array into the destination. That speeds up the process dramatically.

Drawback (or advantage, depending on your needs): Only the values are copied.

Sub CopyRange(sourceRange As Range, destRange As Range, Optional howOften As Long = 1)

    Dim arr As Variant
    ' Fill arr with all values of sourceRange
    arr = sourceRange.Value2
    ' Adjust size of destination range
    Set destRange = destRange.Resize(sourceRange.Rows.count, sourceRange.Columns.count)
    Dim i As Long
    For i = 1 To howOften
        ' Copy the values to the destination
        destRange.Value2 = arr
        ' Move to the next place 
        Set destRange = destRange.Offset(sourceRange.Rows.count)
    Next
End Sub

Assuming that rng is set to the range you want to copy, the call to the routine can look like

call CopyRangeSheets(rng, ThisWorkbook.Sheets("TrialSheet").Range("A1"), 68)

score 0 · Answer 3 · edited Jun 20 '20 at 09:12

Since no information was available about the size of source range being copied

Following grey areas of the question is assumed as follows

Since 191 Rows X 68 copy X 3 columns take around 10 minutes only (with you code), the range is about 191 Rows X 15 Columns in size
since it has been claimed that code is working Correctly. The Cells of the range (irrespective of their row or column positions) is being copied in column A only (below one and another). Though it contradicts the statement "automate creation of a data table"
Since the cells of the ranges are being copied and pasted. In test case formulas are copied only.

So the code below will just replicate what your code is doing with some increased efficiency. As I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques, depending on the working file condition. Make necessary changes regarding Range etc

Code takes only 2-3 seconds to complete with 191 Rows X 15 columns X 68 Copies:

Sub test()
Dim SrcWs As Worksheet, DstWs As Worksheet, SrcArr As Variant
Dim Rng As Range, cell As Range, DstArr() As Variant
Dim X As Long, Y As Long, Z As Long, i As Long, LastRow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer
Set SrcWs = ThisWorkbook.Sheets("Input Data")
Set DstWs = ThisWorkbook.Sheets("TrialSheet")

Set Rng = SrcWs.Range("A1:O191")
SrcArr = Rng.Formula
    
LastRow = DstWs.Cells(Rows.Count, "A").End(xlUp).Row + 1
Chunk60K = 0
Z = 1
    For X = 1 To UBound(SrcArr, 1)
    For Y = 1 To UBound(SrcArr, 2)
    For i = 1 To 68
        ReDim Preserve DstArr(1 To Z)
        DstArr(Z) = SrcArr(X, Y)
    
        If Z = 60000 Then  ' To Overcome 65K limit of Application.Transpose
        DstWs.Range("A" & Chunk60K * 60000 + LastRow).Resize(UBound(DstArr, 1), 1).Formula = Application.Transpose(DstArr)
        Chunk60K = Chunk60K + 1
        Z = 1
        ReDim DstArr(1 To 1)
        Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
        Else
        Z = Z + 1
        End If
    
    Next i
    Next Y
    Next X

If Z > 1 Then DstWs.Range("A" & Chunk60K * 60000 + LastRow).Resize(UBound(DstArr, 1), 1).Formula = Application.Transpose(DstArr)

Debug.Print "Seconds Taken: " & Timer - tm
End Sub

How Can I Improve The Efficiency of my Loop For a Large Application

3 Answers3