性能下降宏對工作表之間複製線

Question

目前我正在運行VBA從1號工作表對每個副本從一個工作表中的每一行找到另一個工作表中的下一個空閒線粘貼兩次行並添加單元格新創建的線。 我的問題是，我有大約25K線使整個過程需要年齡在運行此，誰能幫我優化我試圖不復制粘貼宏，但我不能使它發揮作用。 由於提前

`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

這是未經測試，但應該告訴你如何使用數組來實現這一目標：

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

我花了一點在所有的卷積和換位工作，但這個是什麼我想出了。

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 

這些值是批量傳輸的，但仍然需要循環通過，因爲目標加倍。