Taking too long to clear table, copy from another workbook, paste, and autofill formulas

Question

In my master workbook I have 1 table in each one of my 4 sheets and in sheet2 and sheet4 I have a couple of columns with IF and VLOOKUP functions at the right of the table.

I am trying to do the following:
Clear content from the 4 tables while maintaining only one row of formulas (in sheet 2 and 4),
Copy the range I want from a table in sheet1 of another workbook (repeat for other sheets),
And paste into the table of sheet1 of master workbook (repeat for other sheets),
Autofill the formulas of the remanining columns (only in sheet 2 and 4).

While the code does it's job, it takes almost 2 hours to perform this task!
Even the Clearcontent of sheet2 takes 8 minutes for just 250 rows which seems ridiculous long time!
Sheet1 has 1000 rows, sheet2 has 250, sheet3 has 1000, sheet4 has 26k rows.

Code seems too big for what it does. What can I do to optimise and speed up the code?
Any viable work around or is this normal?
I have tried Application.Calculation = xlCalculationManual but no improvement.

Sub LoopThroughDirectory()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim MyFile As String
    Dim erow1
    Dim erow2
    Dim erow3
    Dim erow4
    Dim Filepath As String
    Dim wkb As Workbook
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim sht4 As Worksheet
    Dim ero2 As Long
    Dim ero4 As Long
    Dim lastero1 As Long
    Dim lastero2 As Long
    Dim lastero3 As Long
    Dim lastero4 As Long


    Folha1.Activate
    Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
    Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
    Folha2.Activate
    Folha2.Range(Cells(3, 1), Cells(99999, 150)).ClearContents
    Folha2.Range(Cells(2, 1), Cells(99999, 137)).ClearContents
    Folha3.Activate
    Folha3.Range(Cells(3, 1), Cells(99999, 197)).ClearContents
    Folha3.Range(Cells(2, 1), Cells(99999, 197)).ClearContents
    Folha4.Activate
    Folha4.Range(Cells(3, 1), Cells(99999, 152)).ClearContents
    Folha4.Range(Cells(2, 1), Cells(99999, 108)).ClearContents

    Filepath = "C:\Users\carlos\Downloads\Projectos\Teste\"
    MyFile = Dir(Filepath)





    Do While MyFile = "Dados Projectos New"
        If MyFile = "Dados Projectos_Master.xlsm" Then
            Exit Sub
        End If

        Set wkb = Workbooks.Open(Filepath & MyFile)
        Set sht1 = wkb.Sheets("Encomendas")
        Set sht2 = wkb.Sheets("Projectos")
        Set sht3 = wkb.Sheets("Casos")
        Set sht4 = wkb.Sheets("Actividades Serviço")

        wkb.Activate
        sht1.Activate
        With Sheets("Encomendas") 'Last row of the first sheet I want to copy
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                lastero1 = .Range("A:fq").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With
        Range("a2:fq" & lastero1).Copy
        Folha1.Activate
        'last row of the first sheet  of master workbook I want to paste
        erow1 = Folha1.Cells.Find("*", After:=Range(Cells(Rows.Count, 173), Cells(Rows.Count, 173)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

        ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Encomendas").Range(Cells(erow1 + 1, 1), Cells(erow1 + 1, 173))





        wkb.Activate
        sht2.Activate

        With Sheets("Projectos") 'Last row of the second sheet I want to copy
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                lastero2 = .Range("A:EG").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With

        Range("a2:Eg" & lastero2).Copy
        Folha2.Activate

        With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to paste
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                erow2 = .Range("A:EG").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With

        ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Projectos").Range(Cells(erow2 + 1, 1), Cells(erow2 + 1, 137))

        With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to autofill
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                ero2 = .Range("A:EG").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With
        Range("EH2:ET2").AutoFill Destination:=Range("EH2:ET" & ero2)

        wkb.Activate
        sht3.Activate
        With Sheets("Casos") 'Last row of the third sheet I want to copy
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                lastero3 = .Range("A:go").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With
        Range("a2:go" & lastero3).Copy

        'Last row of the third sheet of master workbook I want to paste
        erow3 = Folha3.Cells.Find("*", After:=Range(Cells(Rows.Count, 197), Cells(Rows.Count, 197)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Folha3.Activate
        ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Casos").Range(Cells(erow3 + 1, 1), Cells(erow3 + 1, 197))

        wkb.Activate
        sht4.Activate
        With Sheets("Actividades Serviço") 'Last row of the fourth sheet I want to copy
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                lastero4 = .Range("A:dd").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With
        Range("a2:dd" & lastero4).Copy


        ActiveWorkbook.Close
        Folha4.Activate
        With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to paste
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                erow4 = .Range("A:DD").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If


        End With

        ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Actividades serviço").Range(Cells(erow4 + 1, 1), Cells(erow4 + 1, 108))
        With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to autofill
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                ero4 = .Range("A:DD").Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

            End If
        End With
        Range("de2:EV2").AutoFill Destination:=Range("de2:Ev" & ero4)

        MyFile = Dir
    Loop

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

If you have working code which merely needs improvements then you're probably in the wrong place with this post. Code Review is where they handle existing / working code and do their upmost to improve it in terms of speed, security, sustainability, and longevity. Give it a try. They're good! — Ralph
I really think this has to do more with the spreadsheet/computer then the macro if clearing contents takes minutes something is wrong. Does it still take 8 minutes if you just run that line of code on its own? clearing 100000x150 cells takes me about a second (randomly generated data). — gtwebb
Pls try Application.EnableEvents = False while executing the macro... Or ensure there are no events running like Worksheet_Change. Also Application.Calculation = xlCalculationManual may speed it up a lot... — Dirk Reichel
@gtwebb , it takes around 8 minutes to clear just sheet2 with just that line of code. All my data is in a table and it has some table formats and formulas at the right end of the table in sheet2...maybe it is because of the formulas, because sheet1 clears fast. Don't think it is computer related. — carlos_cs
@Dirk Reichel I don't fully understand what events and manual can do and it might ruin the code. You sure it doesn't mess up with this code? — carlos_cs

Doug Coats Doug Coats · Accepted Answer · 2016-05-09T16:26:25

Issues I see so far:

Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents

You don’t need to activate since youre quite literally telling it where to clear contents.

 Range("a2:fq" & lastero1).Copy

No need to copy, you can literally saying something like “Range(“a1”).Value = Range(“C2”).Value. This also means by extension that you don’t have to paste as well.

Some of the major performance tips for macros suggest not to “Copy/Paste” as well as try to avoid “selecting” and “activating.” In fact, directly manipulating worksheets is often seen as cardinal sin.

With larger data sets that need to be moved around, storing everything in an array before dumping to new locations also saves big on time.

Hopes this helps.

Taking too long to clear table, copy from another workbook, paste, and autofill formulas

1 Answers