Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
ENCURTAR/MELHORIA C...
 
Notifications
Clear all

ENCURTAR/MELHORIA CÓDIGO VBA GRANDE

 
2024 - VBA & Macros
Post Recente por guimatheus 7 anos atrás
4 Posts
2 Usuários
0 Reactions
1,079 Visualizações
RSS
 guimatheus
(@guimatheus)
Posts: 30
Eminent Member
Topic starter
 

Pessoal, boa tarde!

Tenho uma macro grande que se eu rodo ela passo a passo (tecla F8), ela roda normalmente. Mas se eu dou play, ela acaba travando e reinicia o excel sozinho, e entra naquele modo de recuperação do excel.

Vocês poderiam me ajudar a encurtar a macro para ver se é o tamanho do processamento ?

Sub consolidado()

Dim sPath As String, sName As String, fName As String
Dim r As Long, rTemp As Long
Dim shPadrao As Worksheet

'Para a macro executar mais rápido!
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Application.DisplayStatusBar = False
    .Application.EnableEvents = False
    .ActiveSheet.DisplayPageBreaks = False
End With

'A planilha onde serão colados os dados
Set shPadrao = ActiveWorkbook.ActiveSheet

'O caminho onde as planilhas que serão lidas estão
sPath = "K:Divisao_Administrativa_FinanceiraTesourariaContas_ReceberLIQUIDO DE COBRANÇALIQ COBLIQ COB 20171 JANEIRO"
'sPath = Sheets("Validação de Dados").Range("K5").Value

'Descubro o nome do primeiro arquivo a ser aberto
sName = Dir(sPath & "*.xl*")
'sName = "RET 13 01 2017.xlsb"

'Faço o loop que le todos os arquivos
Do While sName <> ""
    
    'Acha a ultima linha utilizada na planilha onde serao colados os dados
    'r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row
    
    'O caminho + o nome do arquivo a ser aberto
    fName = sPath & sName
    
    'Abro o workbook a ser lido
    Workbooks.Open Filename:=fName, UpdateLinks:=False
    
    Application.AutomationSecurity = msoAutomationSecurityLow
    
    'Limpo qualquer filtro
    Sheets("Planos de Saúde").Select
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData

'Copia dados liquido
If Range("A3") <> "" Then
    If Range("A4") <> "" Then
        Range("A3").Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.Copy
        Windows("Consolidado Planos de Saúde.xlsb").Activate
        Planilha1.Select
        If Range("A2") <> "" Then
        Range("A2").Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
            Else
        Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        End If
        
'Copia Dt Liquido
Windows(sName).Activate
Sheets("Liq_cobrança do dia").Select
Range("F3").Copy
Windows("Consolidado Planos de Saúde.xlsb").Activate
Planilha1.Select
If Range("J2") <> "" Then
Range("J2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, -1).Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Else
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, -1).Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
End If

'Copia Dt Pagamento
Windows(sName).Activate
Sheets("Planos de Saúde").Select
Range("F1").Copy
Windows("Consolidado Planos de Saúde.xlsb").Activate
Planilha1.Select
If Range("K2") <> "" Then
Range("K2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, -1).Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Else
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, -1).Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
End If
        
    Else
        
'Se tiver só uma linha pra copiar

Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Consolidado Planos de Saúde.xlsb").Activate
Planilha1.Select
If Range("A2") <> "" Then
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Else
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
End If
    
'Copia Dt Liquido
Windows(sName).Activate 'deve mudar o nome do código do "windows", pois muda de planilha toda hora
Sheets("Liq_cobrança do dia").Select
Range("F3").Select
Selection.Copy
Windows("Consolidado Planos de Saúde.xlsb").Activate
Planilha1.Select
If Range("J2") <> "" Then
Range("J2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Else
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
End If

'Copia Dt Pagamento
If Range("K2") <> "" Then
Range("K2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows(sName).Activate
Sheets("Planos de Saúde").Select
Range("F1").Copy
Windows("Consolidado Planos de Saúde.xlsb").Activate
Planilha1.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Else
Windows(sName).Activate
Sheets("Planos de Saúde").Select
Range("F1").Copy
Windows("Consolidado Planos de Saúde.xlsb").Activate
Planilha1.Select
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
End If

End If
End If

Windows(sName).Activate
      
    'Fecho o arquivo já lido
    ActiveWorkbook.Close SaveChanges:=False
    
ScapeB:
    
    'Atualizo a variavel com funcao DIR() que acha o proximo arquivo nao processado
    sName = Dir()
    
Loop

On Error GoTo 0

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Application.DisplayStatusBar = True
    .Application.EnableEvents = True
    .ActiveSheet.DisplayPageBreaks = True
End With

End Sub
 
Postado : 19/04/2018 1:36 pm
 guimatheus
(@guimatheus)
Posts: 30
Eminent Member
Topic starter
 

Pessoal, me ajudem a encurtar o código por favor, ele trava no meio da macro, mas se eu vou passo a passo ela funciona.

 
Postado : 23/04/2018 8:32 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

O tópico a seguir é semelhante ao seu:

http://www.planilhando.com.br/forum/viewtopic.php?f=10&t=28067

Creio que a parte abaixo está errada, pois acabou de colar, pede para copiar novamente, mas sem selecionar outro invervalo que deve ser copiado:

Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy

O uso de select e activate deixa a execução mais lenta.
É possível copiar valores sem select nem activate.
Por exemplo:

sheets("Plan1").Range("B2").value = sheets("Plan2").range("A1").value
 
Postado : 23/04/2018 8:44 am
 guimatheus
(@guimatheus)
Posts: 30
Eminent Member
Topic starter
 

O tópico a seguir é semelhante ao seu:

http://www.planilhando.com.br/forum/viewtopic.php?f=10&t=28067

Creio que a parte abaixo está errada, pois acabou de colar, pede para copiar novamente, mas sem selecionar outro invervalo que deve ser copiado:

Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy

O uso de select e activate deixar a execução mais lenta.
É possível copiar valores sem select nem activate.
Por exemplo:

sheets("Plan1").Range("B2").value = sheets("Plan2").range("A1").value

No código que você falou acima, eu copio a mesma célula na nova aba que eu colei em seguida da colagem, mas vou verificar se é necessário esse passo novamente.

 
Postado : 23/04/2018 11:13 am
Forum Jump:
  Tópico Anterior
Próximo Tópico