Jump to content
Fórum Script Brasil
  • 0

Como deixar minha macro mais rápida?


Question

Boa noite!

Tenho uma macro que carrega o conteúdo de um arquivo .CSV para uma planilha do Excel e arruma (remove todos espaços) todas as linhas da coluna A.

O problema é que quando o arquivo .CSV é muito grande, leva muito tempo para executar.

Parte do código que arruma as células e gera lentidão:

    ' Função arrumar
    Dim rng As Range
    For Each rng In Selection
    If Len(rng) > 0 Then
    rng = Trim$(rng)
    End If
    Next rng

Código completo:

Sub Carregar_Local_Picking()
    
    ' Habilita o tratamento de erros
    On Error GoTo Trata_Erro

    ' Setar configurações de tela para executar a rotina
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
 
    ' Desproteger planilha
    Sheets("LOCAL PICKING").Unprotect Password:="100*Aprovado"
    
    ' Mensagem ao usuário
    MsgBox "Selecione o arquivo de Locações de Picking do CD STD Parts mais recente (.CSV)!" & vbCrLf & vbCrLf & "Atenção: Este arquivo é o Relatório de Locações extraído do JDE no dia de hoje!"
    
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
            .Filters.Clear
            .Title = "Selecione o arquivo de Locais SP"
            .Filters.Add "Relatório JDE", "*.csv", 1
            .AllowMultiSelect = False
            .InitialView = msoFileDialogViewDetails
            .InitialFileName = ThisWorkbook.Path & "\"
            
    ' Ações condicionadas à seleção de um arquivo
    If .Show <> 0 Then
    
    ' Carregar arquivo
    Dim sFile As String
    sFile = .SelectedItems(1)
    
    ' Limpar aba
    Sheets("LOCAL PICKING").UsedRange.ClearContents
    
    ' Trazer mensagem para usuário na barra de status
    Application.StatusBar = "Aguarde. O arquivo está sendo carregado. Isso pode levar algum tempo."

    With Worksheets("LOCAL PICKING").QueryTables.Add(Connection:="TEXT;" & sFile, _
    Destination:=Worksheets("LOCAL PICKING").Range("A1"))
            .RefreshStyle = xlOverwriteCells
            .TextFileStartRow = 4
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .Refresh BackgroundQuery:=False
    End With

    ' Ativar planilha corrente
    Windows(ThisWorkbook.Name).Activate

    ' Ativar aba "LOCAL PICKING" da planilha corrente
    Sheets("LOCAL PICKING").Activate
    
    ' Contar número de linhas
    numeroRegistros = Sheets("LOCAL PICKING").Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Selecionar intervalo de células
    ActiveSheet.Range("A1:A" & numeroRegistros).Select
    
    ' Função arrumar
    Dim rng As Range
    For Each rng In Selection
    If Len(rng) > 0 Then
    rng = Trim$(rng)
    End If
    Next rng

    ' Ativar aba "LISTA DE ROMANEIO" da planilha corrente
    Sheets("INSTRUÇÕES").Activate
    
    ' Proteger planilha
    Sheets("LOCAL PICKING").Protect Password:="100*Aprovado"
 
    ' Ocultar planilha
    Sheets("LOCAL PICKING").Visible = False
    
    ' Ocultar mensagem na barra de status
    Application.StatusBar = False

    ' Informar carregamento
    MsgBox "Arquivo de Locais de Picking carregado com sucesso!"
    
    ' Ativar aba "LISTA DE ROMANEIO" da planilha corrente
    Sheets("INSTRUÇÕES").Activate

    ' Informar status
    Range("E11").Formula = "=NOW()"
    ActiveSheet.Range("E11").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Else
    
    ' Informar não carregamento
    MsgBox "Não foi possível carregar o arquivo. Tente novamente!"

    End If

    End With

Exit Sub

' Início da rotina de tratamento de erros
Trata_Erro:

    MsgBox "Ocorreu um erro na execução do aplicativo. Por favor, tente novamente ou capture a tela e contate o programador."

End Sub

 

 

Link to post
Share on other sites

1 answer to this question

Recommended Posts

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.



  • Forum Statistics

    • Total Topics
      148875
    • Total Posts
      644916
×
×
  • Create New...