Excel VBA需要很长时间才能将日期从一个工作簿复制到另一个工作簿

Question

我正在尝试使用VBA将数据从一个Excel复制到另一个。但它的30K线路耗时超过15分钟。有没有办法让它更快？

我需要将新报表工作簿中的39列与ACQ047 WB对齐。

以下是我的代码：

Sub alignment()

Dim x As Workbook
Dim y As Workbook

Set x = Workbooks.Open("C:\Users\raja\Desktop\New Report.xls")
Set y = Workbooks.Open("C:\Users\raja\Desktop\ACQ047.xlsx")

Dim Lastrow As Long


y.Sheets("unmached").Range("A2").Activate
y.Sheets("unmached").Rows(ActiveCell.Row & ":" & Rows.Count).Delete Shift:=xlUp




x.Sheets("New Report").Rows(1).EntireRow.Delete
x.Sheets("New Report").Range("A1").EntireRow.Insert
Lastrow = x.Sheets("New Report").Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False '!!!!
Application.Calculation = xlCalculationManual '!!!!

For i = 1 To Lastrow
CopyVal = x.Sheets("New Report").Range("A1").Offset(i, 2).Value
CopyVal2 = x.Sheets("New Report").Range("A1").Offset(i, 6).Value
CopyVal3 = x.Sheets("New Report").Range("A1").Offset(i, 8).Value
CopyVal4 = x.Sheets("New Report").Range("A1").Offset(i, 11).Value
CopyVal5 = x.Sheets("New Report").Range("A1").Offset(i, 12).Value
CopyVal6 = x.Sheets("New Report").Range("A1").Offset(i, 14).Value
CopyVal7 = x.Sheets("New Report").Range("A1").Offset(i, 16).Value
CopyVal8 = x.Sheets("New Report").Range("A1").Offset(i, 18).Value
CopyVal9 = x.Sheets("New Report").Range("A1").Offset(i, 19).Value
CopyVal10 = x.Sheets("New Report").Range("A1").Offset(i, 20).Value
CopyVal11 = x.Sheets("New Report").Range("A1").Offset(i, 21).Value
CopyVal12 = x.Sheets("New Report").Range("A1").Offset(i, 22).Value
CopyVal13 = x.Sheets("New Report").Range("A1").Offset(i, 23).Value
CopyVal14 = x.Sheets("New Report").Range("A1").Offset(i, 25).Value
CopyVal15 = x.Sheets("New Report").Range("A1").Offset(i, 26).Value
CopyVal16 = x.Sheets("New Report").Range("A1").Offset(i, 28).Value
CopyVal17 = x.Sheets("New Report").Range("A1").Offset(i, 30).Value
CopyVal18 = x.Sheets("New Report").Range("A1").Offset(i, 32).Value
CopyVal19 = x.Sheets("New Report").Range("A1").Offset(i, 33).Value
CopyVal20 = x.Sheets("New Report").Range("A1").Offset(i, 35).Value
CopyVal21 = x.Sheets("New Report").Range("A1").Offset(i, 40).Value
CopyVal22 = x.Sheets("New Report").Range("A1").Offset(i, 41).Value
CopyVal23 = x.Sheets("New Report").Range("A1").Offset(i, 49).Value
CopyVal24 = x.Sheets("New Report").Range("A1").Offset(i, 50).Value
CopyVal25 = x.Sheets("New Report").Range("A1").Offset(i, 46).Value
CopyVal26 = x.Sheets("New Report").Range("A1").Offset(i, 48).Value
CopyVal27 = x.Sheets("New Report").Range("A1").Offset(i, 43).Value
CopyVal28 = x.Sheets("New Report").Range("A1").Offset(i, 29).Value
CopyVal29 = x.Sheets("New Report").Range("A1").Offset(i, 53).Value
CopyVal30 = x.Sheets("New Report").Range("A1").Offset(i, 54).Value
CopyVal31 = x.Sheets("New Report").Range("A1").Offset(i, 55).Value
CopyVal32 = x.Sheets("New Report").Range("A1").Offset(i, 56).Value
CopyVal33 = x.Sheets("New Report").Range("A1").Offset(i, 57).Value
CopyVal34 = x.Sheets("New Report").Range("A1").Offset(i, 59).Value
CopyVal35 = x.Sheets("New Report").Range("A1").Offset(i, 60).Value
CopyVal36 = x.Sheets("New Report").Range("A1").Offset(i, 61).Value
CopyVal37 = x.Sheets("New Report").Range("A1").Offset(i, 62).Value
CopyVal38 = x.Sheets("New Report").Range("A1").Offset(i, 63).Value
CopyVal39 = x.Sheets("New Report").Range("A1").Offset(i, 64).Value



  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 38).Value = CopyVal39
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 37).Value = CopyVal38
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 36).Value = CopyVal37
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 35).Value = CopyVal36
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 34).Value = CopyVal35
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 33).Value = CopyVal34
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 32).Value = CopyVal33
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 31).Value = CopyVal32
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 30).Value = CopyVal31
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 29).Value = CopyVal30
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 28).Value = CopyVal29
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 27).Value = CopyVal28
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 26).Value = CopyVal27
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 25).Value = CopyVal26
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 24).Value = CopyVal25
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 23).Value = CopyVal24
  y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 22).Value = CopyVal23
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 21).Value = CopyVal22
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 20).Value = CopyVal21
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 19).Value = CopyVal20
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 18).Value = CopyVal19
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 17).Value = CopyVal18
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 16).Value = CopyVal17
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 15).Value = CopyVal16
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 14).Value = CopyVal15
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 13).Value = CopyVal14
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 12).Value = CopyVal13
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 11).Value = CopyVal12
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 10).Value = CopyVal11
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 9).Value = CopyVal10
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 8).Value = CopyVal9
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 7).Value = CopyVal8
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 6).Value = CopyVal7
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 5).Value = CopyVal6
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 4).Value = CopyVal5
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 3).Value = CopyVal4
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 2).Value = CopyVal3
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 1).Value = CopyVal2
y.Sheets("Unmached").Range("A1048576").End(xlUp).Offset(1, 0).Value = CopyVal

Next


Application.Calculation = xlCalculationAutomatic '!!!!
Application.ScreenUpdating = True '!!!

y.Sheets("unmached").Range("A1").Select

ActiveWorkbook.Close SaveChanges:=True

x.Sheets("New Report").Range("A1").Select

ActiveWorkbook.Close SaveChanges:=False

MsgBox " Report Generated"



End Sub

Answer 1

您可以使用以下代码作为如何通过仅访问工作表两次来执行此类任务的示例。一般来说，我尽量避免在VBA中复制和粘贴，但这样可以加快速度

Sub Test()
    x.Sheets("New Report").Range("A:A,C:C,E:E").Copy
    y.Sheets("Unmached").Range("A1").PasteSpecial xlPasteAll
End Sub

Answer 2

我用55k行的数字进行了测试，大约需要45秒。

我只是将原始数据输入到一个数组中，然后通过数组循环将数据放回到新工作表中。

您需要确认我是否捕获了正确的细胞等。

Option Explicit

Sub alignment()

    Dim x As Workbook
    Dim y As Workbook

    Set x = Workbooks.Open("C:\Users\raja\Desktop\New Report.xls")
    Set y = Workbooks.Open("C:\Users\raja\Desktop\ACQ047.xlsx")


    y.Sheets("unmached").Range("A2").Activate
    y.Sheets("unmached").Rows(ActiveCell.Row & ":" & Rows.Count).Delete Shift:=xlUp
    x.Sheets("New Report").Rows(1).EntireRow.Delete
    x.Sheets("New Report").Range("A1").EntireRow.Insert

    Dim Lastrow As Long
    Lastrow = x.Sheets("New Report").Range("A" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False '!!!!
    Application.Calculation = xlCalculationManual '!!!!

    Dim DataArray As Variant
    ReDim DataArray(39)

    For i = 1 To Lastrow

        With x.Sheets("New Report").Range("A1")

            DataArray = Array(.Offset(i, 2).Value, .Offset(i, 6).Value, .Offset(i, 8).Value, _
                              .Offset(i, 11).Value, .Offset(i, 12).Value, .Offset(i, 14).Value, _
                              .Offset(i, 16).Value, .Offset(i, 18).Value, .Offset(i, 19).Value, _
                              .Offset(i, 20).Value, .Offset(i, 21).Value, .Offset(i, 22).Value, _
                              .Offset(i, 23).Value, .Offset(i, 25).Value, .Offset(i, 26).Value, _
                              .Offset(i, 28).Value, .Offset(i, 30).Value, .Offset(i, 32).Value, _
                              .Offset(i, 33).Value, .Offset(i, 35).Value, .Offset(i, 40).Value, _
                              .Offset(i, 41).Value, .Offset(i, 49).Value, .Offset(i, 50).Value, _
                              .Offset(i, 46).Value, .Offset(i, 48).Value, .Offset(i, 43).Value, _
                              .Offset(i, 29).Value, .Offset(i, 53).Value, .Offset(i, 54).Value, _
                              .Offset(i, 55).Value, .Offset(i, 56).Value, .Offset(i, 57).Value, _
                              .Offset(i, 59).Value, .Offset(i, 60).Value, .Offset(i, 61).Value, _
                              .Offset(i, 62).Value, .Offset(i, 63).Value, .Offset(i, 64).Value)

        End With

        With y.Sheets("Unmached").Range("A1048576").End(xlUp)

           Dim ArrayPos As Long

            For ArrayPos = 0 To 38
               .Offset(1, 38 - ArrayPos).Value = DataArray(39 - ArrayPos)
            Next ArrayPos

        End With

    Next i

    Application.Calculation = xlCalculationAutomatic '!!!!
    Application.ScreenUpdating = True '!!!

    y.Sheets("unmached").Range("A1").Select

    ActiveWorkbook.Close SaveChanges:=True

    x.Sheets("New Report").Range("A1").Select

    ActiveWorkbook.Close SaveChanges:=False

    MsgBox " Report Generated"

End Sub

Answer 3

这是符合您要求的代码。这不会超过5-10 SECONDS

根据需要更改工作表名称和工作簿名称并执行一项操作，检查范围是否准确。希望你有这个想法让我知道你是否仍然面临问题 -

Application.ScreenUpdating = False

Dim ws1, ws2 As Workbook

Set ws1 = ThisWorkbook
Set ws2 = Workbooks.Open("E:\Praveen Behera files\book2.xlsx")

'l is lastrow
 l = ws1.sheets("Sheet1").range("A500000").end(xlup).row

ws1.Sheets("Sheet1").Range("" & "C2:C" & l & ",G2:G" & l & ",I2:I" & l & ",L2:L" & l & ",M2:M" & l & ",O2:O" & l & ",Q2:Q" & l & ",S2:S" & l & ",T2:T" & l & ",U2:U" & l & ",V2:V" & l & ",W2:W" & l & ",X2:X" & l & ",Z2:Z" & l & ",AA2:AA" & l & ",AC2:AC" & l & ",AD2:AD" & l & ",AE2:AE" & l & ",AG2:AG" & l & ",AH2:AH" & l & ",AJ2:AJ" & l & ",AO2:AO" & l & ",AP2:AP" & l & ",AR2:AR" & l & ",AU2:AU" & l & ",AW2:AW" & l & ",AX2:AX" & l & ",AY2:AY" & l & ",BB2:BB" & l & ",BC2:BC" & l & ",BD2:BD" & l & "").Copy Destination:=ws2.Sheets("Sheet1").Range("A2")

ws1.Sheets("Sheet1").Range("" & "BE2:BE" & l & ",BF2:BF" & l & ",BH2:BH" & l & ",BI2:BI" & l & ",BJ2:BJ" & l & ",BK2:BK" & l & ",BL2:BL" & l & ",BM2:BM" & l & "").Copy Destination:=ws2.Sheets("Sheet1").Range("AF2")

Application.ScreenUpdating = True