Loop to copy values from one sheet and paste the values 68 times in another, time efficiency 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" &amp; LastRow).Select
        ActiveSheet.Paste
    Next i

    Sheets("Input Data").Select

Next cell

Application.ScreenUpdating = True
Since no information was available about the size of source range being copied
Following grey area in 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 another). Though it contradicts the statement &quot;automate creation of a data table&quot;

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(&quot;Input Data&quot;)
Set DstWs = ThisWorkbook.Sheets(&quot;TrialSheet&quot;)

Set Rng = SrcWs.Range(&quot;A1:O191&quot;)
SrcArr = Rng.Formula
    
LastRow = DstWs.Cells(Rows.Count, &quot;A&quot;).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(&quot;A&quot; &amp; Chunk60K * 60000 + LastRow).Resize(UBound(DstArr, 1), 1).Formula = Application.Transpose(DstArr)
        Chunk60K = Chunk60K + 1
        Z = 1
        ReDim DstArr(1 To 1)
        Debug.Print &quot;Chunk: &quot; &amp; Chunk60K &amp; &quot; Seconds Taken: &quot; &amp; Timer - tm
        Else
        Z = Z + 1
        End If
    
    Next i
    Next Y
    Next X

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

Debug.Print &quot;Seconds Taken: &quot; &amp; 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(&quot;Input Data&quot;)
Set DstWs = ThisWorkbook.Sheets(&quot;TrialSheet&quot;)
Set Rng = SrcWs.Range(&quot;A1:O191&quot;)
SrcArr = Rng.Formula
Repeat = 68
ReDim DstArr(1 To (Repeat * Rng.Count), 1 To 1)
Lastrow = DstWs.Cells(Rows.Count, &quot;A&quot;).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(&quot;A&quot; &amp; Lastrow).Resize(UBound(DstArr, 1), 1).Formula = DstArr
Debug.Print &quot;Seconds Taken: &quot; &amp; Timer - tm
End Sub