2
\$\begingroup\$

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.

Application.ScreenUpdating = False

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

Application.ScreenUpdating = True
\$\endgroup\$
  • \$\begingroup\$ Is the posted code working as you intend? Your description states that you have "191 rows that need to be copied", but your code is only copying a single cell. And your rng variable is never set to any range on a worksheet. \$\endgroup\$ – PeterT Jul 3 at 14:21
  • \$\begingroup\$ it is working fine yes. This is a small portion of a larger VBA code block. This one loop is what is causing me time issues. I set the range earlier in the code \$\endgroup\$ – MULaker Jul 3 at 14:43
  • \$\begingroup\$ In order to get a complete review of your code, it's best to read this guide on how to get the best value out of Code Review. Ideally and in most cases, we're expecting to be able to copy/paste your code into our own spreadsheet, fake some data, and run it. Your example doesn't give us enough context for a complete review. If you don't wish to post a more complete example for a full review, you may get the help from the Stack Overflow site. \$\endgroup\$ – PeterT Jul 3 at 15:54
  • \$\begingroup\$ okay, I will head over there then. Thanks. \$\endgroup\$ – MULaker Jul 3 at 17:30
1
\$\begingroup\$

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

Following grey area in the question is assumed as follows

  1. 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
  2. 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 another). Though it contradicts the statement "automate creation of a data table"
  3. Since the cells of the ranges are being copied and pasted. In test case only formulas are copied.

    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

Edit: With full credit to @TinMan's brilliant suggestion in his comment, the code has been modified (efficiency improved around 65%). The inherent deficiency in the above code is use of ReDim Preserve within the loop has been removed. This enabled use of 2D array and eliminates necessity of transposing the array. Again with many thanks to TinMan and acknowledging full credit to TinMan, The final simplified code as follows.

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 Repeat 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
Repeat = 68
ReDim DstArr(1 To (Repeat * Rng.Count), 1 To 1)
Lastrow = DstWs.Cells(Rows.Count, "A").End(xlUp).Row + 1
Z = 1

    For X = 1 To UBound(SrcArr, 1)
    For Y = 1 To UBound(SrcArr, 2)
    For i = 1 To Repeat
    DstArr(Z, 1) = SrcArr(X, Y)
    Z = Z + 1
    Next i
    Next Y
    Next X

DstWs.Range("A" & Lastrow).Resize(UBound(DstArr, 1), 1).Formula = DstArr
Debug.Print "Seconds Taken: " & Timer - tm
End Sub
\$\endgroup\$
  • \$\begingroup\$ You did a good job of recreating the output using arrays. But your code could be simplified. Since each value in Rng is being repeated 68 times, we can determine that 68 * Rng.Count is the optimal size of DstArr (e.g.ReDim DstArr(1 To (68 * Rng.Count), 1 To 1) ). Making these changes improved the performance by %68.5 in my test. \$\endgroup\$ – TinMan Jul 4 at 11:25
  • \$\begingroup\$ @TinMan thanks again for your brilliant Idea. Post edited with your suggestion. In realty the full credit is yours only. \$\endgroup\$ – Ahmed AU Jul 5 at 0:42
  • \$\begingroup\$ You did the hard work I simply tweaked it. I couple little details: Repeat should be a constant value. Z = 1 can be removed by incremenling Z before the DstArr(Z, 1) = SrcArr(X, Y). Nice work. \$\endgroup\$ – TinMan Jul 6 at 14:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.