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

Boa noite! Pessoal, Poderiam me ajudar por favor? Estou com uma tabela, onde tenho de somar todos os campos destacados na cor amarela. O somases direto não funciona, pois retorna 0. Como eu faço para somar todos os campos destacados em amarelo sem ter de utilizar vários somases+somases+somases....etc(pois a formula fica muito grande e não aceita no vba). Planilha modelo está em anexo no link.arquivo base

Bom dia pessoal! Poderiam me ajudar por favor? Tenho uma base de dados e gostaria de realizar um comparativo da evolução diária por item e valor. Por exemplo, no endereço T99000000001Z no dia 03/ago eu tinha 3 unidades do item 133111 a um custo unitário de R$ 51,97, totalizando R$ 155,92. Porém, já no dia 04/ago eu tinha apenas 1 unidade desse mesmo item nesse endereço T99000000001Z. Ou seja, do dia 03 para o dia 04 de agosto, eu tive a retirada de 2 unidades do item 133111 do endereço T99000000001Z totalizando R$ 103,95. Eu gostaria de ver essas informações/evolução diariamente, por exemplo, todos os itens, quantidades e valores que coloquei ou retirei de cada endereço. Poderia escolher um período por exemplo, do dia 01/ago à 05/ago, tudo que retirei e coloquei, ou do dia 01/ago ao dia 02/ago. de forma que eu pudesse escolher esse período de analise manualmente sabe? Agradeço muito a ajuda. Abs. Planilha modelo no link em anexo. Planilha base de endereços