Выполнение этого макроса занимает много времени, что можно сделать, чтобы ускорить его?

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