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

  • Pergunta

  • 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


    segunda-feira, 4 de abril de 2016 18:32

Respostas

  • 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

    quinta-feira, 7 de abril de 2016 21:03
    Moderador

Todas as Respostas

  • 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

    quinta-feira, 7 de abril de 2016 21:03
    Moderador
  • 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

    sábado, 9 de abril de 2016 22:43