It takes ages to execute this macro, what can be done to speed it up?

Question

I have created macro which loops through workbooks in the folder and copy/paste data to the master spreadsheet. Everything works fine, but it takes +/-10 minutes to complete it...

Is there any way to upgrade the below code or maybe I should try other approach?

The macro loops through 12 sheets in the workbooks and copy the data from the range A7:E21 and takes consultant name from A2 to paste it to the next empty cell in the master sheet.

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

Chuck them all in an `Array Loop` i.e `For every month, run this` — Badja, Mar 14 '19 at 14:44
How long does it take? Thought if the code works you should go to codereview — Damian, Mar 14 '19 at 14:44
Also look into bypassing [copy/paste](https://stackoverflow.com/questions/51405731/avoiding-select-with-copy-and-paste-vba) — cybernetic.nomad, Mar 14 '19 at 14:45
Have you checked to see if the opening of the file is the slow part? I don't know about your environment, but a U:\ drive sounds like a network drive and that could be slow. — Brad, Mar 14 '19 at 15:04
@Brad, yes Sir, this is network drive. Do you think that is the reason why this is slow? — wisniadj, Mar 14 '19 at 15:07
Accessing a network drive is always going to be slower than a local drive. You can try running things by having a local copy of the document being accessed and change the path and see what happens. — Brad, Mar 14 '19 at 15:09
Also, probably a question better suited for [codereview](https://codereview.stackexchange.com/) — Samuel Hulla, Mar 14 '19 at 15:34

It takes ages to execute this macro, what can be done to speed it up?

0 Answers0