Macro para importação de dados arquivo TXT com barra de progresso

Question

Olá pessoal, boa tarde!

Tenho 2 macros já prontas e que funcionam 100%, sendo uma para importar dados de arquivos txt em uma determinada pasta, e outra macro para rodar uma barra de progresso conforme algumas iterações numéricas.

Não estou conseguindo juntar as duas, ou seja, no processo de importação dos arquivos txt eu gostaria que rodasse a barra de progresso, alguem poderia me ajudar por favor ??

Seguem abaixo as duas macros e também link pra download do arquivo "exempo barra progresso"

Sub ComBarras()

    Dim l As Long
    Dim lMin As Long
    Dim lMax As Long
    Dim r As Range
    Dim rTudo As Range
    Dim frm As frmBarraProgresso
    
    'Usando iterações numéricas
    lMin = 1
    lMax = 10000
    Set frm = New frmBarraProgresso
    frm.Min = lMin
    frm.Max = lMax
    frm.Show vbModeless
    For l = lMin To lMax
        Cells(l, "A") = l
        frm.Progresso l
    Next l
    Unload frm

End Sub

Sub ImportarTXT()

Dim Pasta As String
Dim Arquivo As String
Dim LinInicial As Long
Dim LinFinal As Long

'Abre caixa de diálogo para selecionar a pasta onde estão
'os arquivos
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Pasta = .SelectedItems(1)
End With

Arquivo = Dir(Pasta & "\*.txt")


While Arquivo <> ""

Workbooks.OpenText Filename:=Pasta & "\" & Arquivo, _
DataType:=xlDelimited, Other:=True, OtherChar:=";", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))

'Linha inicial onde deve-se colocar o nome do arquivo
LinInicial = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
ActiveSheet.[A1].CurrentRegion.Copy _
ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0)

'Linha final onde deve-se colocar o nome do arquivo
LinFinal = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
ThisWorkbook.ActiveSheet.Cells(LinInicial, "F").Resize(LinFinal - LinInicial, 1).Value = Arquivo
ActiveWorkbook.Close False
Arquivo = Dir
DoEvents
Wend
MsgBox "Fim de Execução da Macro"

End Sub

Link para download: http://www.4shared.com/file/D4URKaTRba/Exemplo_Barra_de_Progresso.html

Desde já agradeço a todos!

Att.

Vinicius

Answer 1

Não use While...Wend, use Do...Loop no seu lugar.

---

Indente seu código.

---

Sub ImportarTXT()
    
    Dim Pasta As String
    Dim Arquivo As String
    Dim LinInicial As Long
    Dim LinFinal As Long
    Dim l As Long
    Dim lMin As Long
    Dim lMax As Long
    Dim iFile As Object
    Dim frm As frmBarraProgresso
    
    'Abre caixa de diálogo para selecionar a pasta onde estão
    'os arquivos
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        Pasta = .SelectedItems(1)
    End With
    
    Arquivo = Dir(Pasta & "\*.txt")
    
    lMin = 1
    For Each iFile In CreateObject("Scripting.FileSystemObject").GetFolder(Pasta).Files
        If LCase(iFile.Name) Like "*.txt" Then lMax = lMax + 1
    Next iFile
    
    Set frm = New frmBarraProgresso
    frm.Min = lMin
    frm.Max = lMax
    frm.Show vbModeless
    Do While Arquivo <> ""
        Workbooks.OpenText Filename:=Pasta & "\" & Arquivo, _
        DataType:=xlDelimited, Other:=True, OtherChar:=";", _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
        
        'Linha inicial onde deve-se colocar o nome do arquivo
        LinInicial = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
        ActiveSheet.[A1].CurrentRegion.Copy _
        ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0)
        
        'Linha final onde deve-se colocar o nome do arquivo
        LinFinal = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
        ThisWorkbook.ActiveSheet.Cells(LinInicial, "F").Resize(LinFinal - LinInicial, 1).Value = Arquivo
        ActiveWorkbook.Close False
        Arquivo = Dir
        DoEvents
        frm.Progresso l
        l = l + 1
    Loop
    Unload frm
    
    MsgBox "Fim de Execução da Macro"
    
End Sub

---

http://www.ambienteoffice.com.br - http://www.clarian.com.br

Answer 2

Olá, boa noite pessoal !

Felipe, ficou perfeito. Funcionou exatamente como eu precisava.

Acrescentei apenas o item "ScreenUpdating = False" para não piscar a tela, e também um tratamento para o erro que dava quando o usuário clicava no botão "Cancelar" da tela FileDialog.

Muito obrigado mesmo, grande abraço!!!

Att.

Vinicius