Excel VBA - Barra de Progresso para várias macros

[levi feirreira]

Boa tarde,

 

preciso criar uma barra de progresso com várias macros. em anexo ela funciona do jeito que fiz, porém no primeiro call ela demora pois o Código é longo,

eu preciso que ela executa a medida que vai lendo os códigos, isso é possível ? Preciso que executa sem fica para o andamento por muito tempo.

 

Muito obrigado 

Sub MxM_()

Application.ScreenUpdating = False

Dim ucel As Long
Dim i As Long, lin As Long, cont As Long


AbrirBarraProgresso
            
            cont = 100
            Call vamp_
            
progredirBarraProgresso (cont / 400)
DoEvents
'cont = cont + 100
            
            cont = 200
            Call AjustarMigo_
            
progredirBarraProgresso (cont / 400)
DoEvents
'cont = cont + 100
            
            cont = 300
            Call AjustarMiro_
            
progredirBarraProgresso (cont / 400)
DoEvents
'cont = cont + 100

            cont = 400
            Call Conclusão_
            
progredirBarraProgresso (cont / 400)
DoEvents
'cont = cont + 100
            


FecharBarraProgresso

Application.ScreenUpdating = True

End Sub


Function AbrirBarraProgresso()

BarraDeProgresso.quadroProgresso.Width = 0

BarraDeProgresso.Show (vbMoldeless)



End Function

Function progredirBarraProgresso(andamento As Double)

WidthTotal = 300
WidthAtual = WidthTotal * andamento

BarraDeProgresso.quadroProgresso.Width = WidthAtual
BarraDeProgresso.textoAndamento.Caption = Round(andamento * 100, 0) & " % Completo"



End Function

Function FecharBarraProgresso()

Unload BarraDeProgresso


End Function

[Midori]

@levi feirreira A barra só é atualizada quando a macro chama a função do progresso, então isso teria que ser feito dentro das subs e não fora. Esses indicadores de progresso funcionam bem com iterações/loops. Se for esse o caso pegue o total geral para depois ir carregando a barra a cada iteração.

[levi feirreira]

Entendo, seria possível atraves de um código VBA saber quantas linhas de sintaxe (scrip/códigos) tem numa macro ?

 

Neste sentido dava para achar o todo e a cada execução de código seria atualizada cada evento.

[Wendell Menezes]

Bom dia,

 

Sim, é possível. Abaixo um exemplo.

 

Antes de testar você precisa:

 

1. Permitir que macros acessem o projeto VBA através do Trust Center:

 

 

2. Ativar a refêrencia abaixo:

 

 

 

 

Sub COUNT_CODE_LINES()

    Dim VBP         As VBProject
    Dim Module      As VBComponent
    Dim lCodeLines  As Long
    
    On Error GoTo Err:
    Set VBP = ThisWorkbook.VBProject
    
    For Each Module In VBP.VBComponents
        lCodeLines = lCodeLines + Module.CodeModule.CountOfLines
    Next
    
    MsgBox lCodeLines
    
Err:
    Set VBP = Nothing

End Sub

[levi feirreira]

Muito obrigado Wendell Menezes,

 

com certeza vou verificar.

 

 

 

Tenho outra dúvida. Se poder ajudar agradeço.:

 

o código busca informações no xml, porém quando chega nesta fase abaixo de cnpj e cpf ele depura, pois tem xml que o destinatário é pessoa física (CPF) e tem destinatário que é pessoa jurídica (CNPJ). 

 

Preciso condicionar um código que atenda os 2 (CPF e CNPJ), o xml que tem como destinatário CPF ele atende o código o CPF , porém quando é CNPJ ele depura.

For Each xmlNode In xmlDoc.getElementsByTagName("dest")


        'Razão social do destinatário
        strDestino = xmlNode.SelectNodes("xNome")(0).Text


        'CNPJ do emitente
        If Len(xmlNode.SelectNodes("CNPJ")(0).Text) = 14 Then
        strCNPJDestino = "'" & xmlNode.SelectNodes("CNPJ")(0).Text
        End If
        
        If Len(xmlNode.SelectNodes("CPF")(0).Text) = 11 Then
        strCNPJDestino = "'" & xmlNode.SelectNodes("CPF")(0).Text
        End If
     
        'Inscrição Estadual do emitente
        If Len(xmlNode.SelectNodes("IE")(0).Text) = 12 Then
        strIEDestino = "'" & xmlNode.SelectNodes("IE")(0).Text
        Else
           strIEDestino = " "
        End If
        
    
        
Next

 

 

[levi feirreira]

Boa tarde, Se puder ajudar agradeço.

 

O primeiro erro o vba atende, mas o segundo não. Porque a função on error funciona na de cima e não na de baixo?

 

Obrigado.

 

[Wendell Menezes]

Boa noite,

 

Não funciona porque você precisa usar "Resume" para dizer ao VBA que você já tratou o primeiro erro e ele pode continuar a execução normalmente. Exemplo:

 

Sub teste()

On Error GoTo Erro1
Sheets("qwert").Select

Sem_Erro:
On Error GoTo Hell
Sheets("asdf").Select

Erro1:
MsgBox "Erro 1"
Resume Sem_Erro

Hell:
MsgBox "Erro 2 :("

End Sub