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
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
Diria q esse negócio de ficar vasculhando por colunas inteiras (TotalLinhas) é a pior coisa q vc pode fazer, p/ evitar isso crie tabelas nomeadas, aprenda a fazer chamadas delas no código e a pesquisar somente no limite delas. Trabalhar com tabelas nomeadas é muito mais fácil e vale a pena o esforço.