Slow performance of VBA Excel macro for duplicating lines between Worksheets

Question

Currently I am running a VBA to copy each line from one worksheet find the next free line in another worksheet paste the line twice and add a cell from the number 1 worksheet to each newly created line. My issue is that I am running this with approximately 25k lines making the whole process take ages, can anyone help me optimize the macro i have tried to not copy paste but i cannot make it work. Thanks in Advance

`Sub eeeee()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer, k As Integer
Dim ws1LR As Long, ws2LR As Long

Set ws1 = Sheets("Bearbejdning")
Set ws2 = Sheets("Bearbejdet")

ws1LR = ws1.Range("B" & Rows.Count).End(xlUp).Row + 1
ws2LR = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1

i = 2
k = ws2LR
Do Until i = ws1LR
    With ws1
        .Range(.Cells(i, 1), .Cells(i, "AN")).Copy
    End With

    With ws2
        .Cells(k, 1).PasteSpecial
        .Cells(k, 1).Offset(1, 0).PasteSpecial
    End With

    ws2.Cells(k, "AP").Value = ws1.Cells(i, "BY").Value
    ws2.Cells(k + 1, "AP").Value = ws1.Cells(i, "BZ").Value

    ws2.Cells(k, "AQ").Value = ws1.Cells(i, "AI").Value
    ws2.Cells(k + 1, "AQ").Value = ws1.Cells(i, "AJ").Value

    k = k + 2
    i = i + 1
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub`

Answer 1

This is untested but should show you how to use arrays to achieve this:

Sub eeeee()
    Dim ws1                   As Worksheet
    Dim ws2                   As Worksheet
    Dim i                     As Long
    Dim k                     As Long
    Dim ws1LR                 As Long
    Dim ws2LR                 As Long
    Dim vDataIn
    Dim vDataIn2
    Dim vDataOut()
    Dim vDataOut2()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set ws1 = Sheets("Bearbejdning")
    Set ws2 = Sheets("Bearbejdet")

    ws1LR = ws1.Range("B" & Rows.Count).End(xlUp).Row
    ws2LR = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
    ReDim vDataOut(1 To (ws1LR - 1) * 2, 1 To 40)
    ReDim vDataOut2(1 To (ws1LR - 1) * 2, 1 To 2)

    With ws1
        vDataIn = .Range(.Cells(2, 1), .Cells(ws1LR, "AN")).Value
        vDataIn2 = .Range(.Cells(2, "BY"), .Cells(ws1LR, "BZ")).Value
    End With

    For i = 1 To (ws1LR - 1)
        For k = 1 To 40
            vDataOut((i - 1) * 2 + 1, k) = vDataIn(i, k)
            vDataOut((i - 1) * 2 + 2, k) = vDataIn(i, k)
        Next k
        vDataOut2((i - 1) * 2 + 1, 1) = vDataIn2(i, 1)
        vDataOut2((i - 1) * 2 + 2, 1) = vDataIn2(i, 2)
        vDataOut2((i - 1) * 2 + 1, 2) = vDataIn(i, 35)
        vDataOut2((i - 1) * 2 + 2, 2) = vDataIn(i, 36)
    Next i
    ws2.Cells(ws2LR, "A").Resize(UBound(vDataOut, 1), UBound(vDataOut, 2)).Value = vDataOut

    ws2.Cells(ws2LR, "AP").Resize(UBound(vDataOut2, 1), UBound(vDataOut2, 2)).Value = vDataOut2

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 2

It took me a bit to work through all the convolutions and transpositions but this is what I came up with.

Sub fffff()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim v As Long, ws1LR As Long, ws2LR As Long
    Dim vSRC As Variant, vAP As Variant, vAQ As Variant

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set ws1 = Sheets("Bearbejdning")
    Set ws2 = Sheets("Bearbejdet")

    ws1LR = ws1.Range("B" & Rows.Count).End(xlUp).Row
    ws2LR = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1

    vSRC = Application.Transpose(ws1.Cells(2, 1).Resize(ws1LR - 1, Columns("AN").Column).Value)
    vAP = Application.Transpose(ws1.Cells(2, Columns("BY").Column).Resize(ws1LR - 1, 2).Value)
    vAQ = Application.Transpose(ws1.Cells(2, Columns("AI").Column).Resize(ws1LR - 1, 2).Value)

    With ws2
        For v = LBound(vSRC, 2) To UBound(vSRC, 2)
            .Cells(ws2LR + 2 * (v - 1), 1).Resize(2, UBound(vSRC, 1)) = _
                Application.Index(Application.Transpose(vSRC), v) 'use INDEX to peel off a row
            .Cells(ws2LR + 2 * (v - 1), Columns("AP").Column).Resize(2, 1) = _
                Application.Transpose(Array(vAP(1, v), vAP(2, v)))
            .Cells(ws2LR + 2 * (v - 1), Columns("AQ").Column).Resize(2, 1) = _
                Application.Transpose(Array(vAQ(1, v), vAQ(2, v)))
        Next v
    End With

    Set ws1 = Nothing
    Set ws2 = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

The values are transferred in bulk but still need to be looped through due to the doubling of the target.