Macro fica lenta a partir da segunda execução.

[RahelCunha]

Bom dia pessoal, tudo bem?

Podem me ajudar por favor?

Tenho uma macro que quando abro o excel e rodo essa macro pela primeira vez, ela executa em uma velocidade muito rápida. Porém, a partir da segunda vez em que ela é executada, ela demora um tempo muito maior para ser concluída. O mais estranho é que, se eu fechar o excel e abrir novamente, de novo a primeira vez é muito rápida e a partir da segunda tentativa ela fica lenta.

Debugando o código, percebi que ela fica lenta na parte do código onde são excluídas apenas as celulas filtradas.

 

Tem alguma sugestão de melhoria no código ou outra forma de executar a mesma tarefa de maneira mais rápida?

Desde já, muito obrigado.

 

Segue link arquivo base utilizado e planilha com a macro em anexo.

https://drive.google.com/drive/folders/19P-W2UVhc7RkDb5Txc_OVdBKs5xqu6Ua?usp=sharing

 

Obrigado.

 

Segue código da macro.

 

Option Explicit

Sub MOVIMENTAÇÕES()
'
' MOVIMENTAÇÕES Macro
'
Dim TotalLinhas As Integer
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

If Range("B1").Value = "" Then
MsgBox ("Cole o arquivo de movimentação do item na célula B1"), vbCritical

Exit Sub
End If

TotalLinhas = Sheets("6670436").Range("B" & Rows.Count).End(xlUp).Row



    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("F:F").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    Range("B1").Select
    Selection.AutoFilter
    With Selection
    ActiveSheet.Range("$B$2:E" & TotalLinhas).AutoFilter Field:=1, Criteria1:="=D*", _
        Operator:=xlOr, Criteria2:="=T*"
        
        
    ActiveSheet.Range("B2:E" & Range("B2" & TotalLinhas).End(xlUp).Row).SpecialCells(xlVisible).EntireRow.Delete
    Range("C1").Value = "ITEM"
    Range("E1").Value = "OBS"
    Cells.Select
    Selection.RowHeight = 19.5
    Cells.EntireColumn.AutoFit
    Columns("E:E").ColumnWidth = 17.86
    Columns("D:D").ColumnWidth = 48.57
    Range("B1").AutoFilter
    ActiveSheet.Range("$B$1:E" & TotalLinhas).RemoveDuplicates Columns:=1, Header:= _
        xlYes
    Range("B1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    ActiveWorkbook.Worksheets("6670436").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("6670436").Sort.SortFields.Add Key:=Range( _
        "B2:B" & TotalLinhas), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("6670436").Sort
        .SetRange Range("B2:E" & TotalLinhas)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B1:E1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 6299648
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    ActiveSheet.PageSetup.PrintArea = "$B:$E"
    Range("B1").Select
    ActiveWorkbook.Worksheets("6670436").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("6670436").Sort.SortFields.Add Key:=Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("6670436").Sort
        .SetRange Range("B1:E" & TotalLinhas)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$B:$E"
    
    Columns("B:D").EntireColumn.AutoFit
    

Range("E2").Select
    
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
    
    
    
End Sub

Sub LIMPAR()
'
' LIMPAR Macro
'
Dim TotalLinhas As Integer

TotalLinhas = Sheets("6670436").Range("B" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False

    Range("B1:B" & TotalLinhas).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlUp
    Range("B1").Select
End Sub

 

Editado Outubro 29, 2021 por RahelCunha
erro link