执行此宏需要花费很多时间，如何做才能加快速度？

Question

我创建了宏，该宏在文件夹中的工作簿之间循环，并将数据复制/粘贴到主电子表格。一切正常，但需要+/- 10分钟才能完成...

有什么办法可以升级下面的代码，或者我应该尝试其他方法？

该宏在工作簿中循环浏览12个工作表，并复制范围A7:E21中的数据，并从A2中获取顾问名称，以将其粘贴到母版工作表中的下一个空单元格中。

Sub copyworkbooks()

Application.ScreenUpdating = False

Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsJanuary As Worksheet
Dim wsFebruary As Worksheet
Dim wsMarch As Worksheet
Dim wsApril As Worksheet
Dim wsMay As Worksheet
Dim wsJune As Worksheet
Dim wsJuly As Worksheet
Dim wsAugust As Worksheet
Dim wsSeptember As Worksheet
Dim wsOctober As Worksheet
Dim wsNovember As Worksheet
Dim wsDecember As Worksheet
Dim wsTarget As Worksheet
Dim i As Integer

i = 1

'change path here
strPath = "U:\Figuers\Data Figures\"

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

Set wsTarget = Workbooks("Scrap.xlsm").Worksheets("Sheet1")

strFile = Dir(strPath & "*.xlsx*")

On Error Resume Next

wsTarget.Range("A2:F1000000").ClearContents

Do Until strFile = ""

If strFile <> ThisWorkbook.Name Then

Set wbSource = Workbooks.Open(strPath & strFile)
Set wsJanuary = wbSource.Worksheets("January")
Set wsFebruary = wbSource.Worksheets("February")
Set wsMarch = wbSource.Worksheets("March")
Set wsApril = wbSource.Worksheets("April")
Set wsMay = wbSource.Worksheets("May")
Set wsJune = wbSource.Worksheets("June")
Set wsJuly = wbSource.Worksheets("July")
Set wsAugust = wbSource.Worksheets("August")
Set wsSeptember = wbSource.Worksheets("September")
Set wsOctober = wbSource.Worksheets("October")
Set wsNovember = wbSource.Worksheets("November")
Set wsDecember = wbSource.Worksheets("December")

'january loop
wsJanuary.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsJanuary.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'feb loop
wsFebruary.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsFebruary.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'march loop
wsMarch.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsMarch.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'April loop
wsApril.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsApril.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'may loop
wsMay.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsMay.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'june loop
wsJune.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsJune.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'July loop
wsJuly.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsJuly.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'August loop
wsAugust.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsAugust.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'Septemberloop
wsSeptember.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsSeptember.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'Octoberloop
wsOctober.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsOctober.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'Novloop
wsNovember.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsNovember.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

'Decemberloop
wsDecember.Range("A7:E21").copy
wsTarget.Cells(i, 1).Offset(1, 1).PasteSpecial xlPasteValues
wsDecember.Range("A2").copy
wsTarget.Cells(i, 1).Offset(1, 0).PasteSpecial xlPasteValues
i = i + 15

Application.DisplayAlerts = False
wbSource.Close
Application.DisplayAlerts = True

End If

strFile = Dir()
Loop

Application.ScreenUpdating = True

End Sub