none
Extração de dados de um .txt em linhas especificas RRS feed

  • Pergunta

  • Olá, prezados.

    Estou criando um código que irá automatizar os relatórios no trabalho a partir de um button. O equipamento de medição me da um arquivo em .mmf ou .txt, e tem uma parte importante que estou quebrando a cabeça para conseguir resolver e estou a uns dias sem avançar. 

    Abaixo é o texto que quero extrair, os dados (números separados por ponto e vírgula) sempre tem a mesma quantidade de colunas e as linhas variam de acordo com a medição feita. Quero descobrir a forma de retirar tudo que está entre "MWTTanDeltaValues=" até "MWTTanDeltaTimeValues=" e colar na planilha. Segue uma parte do arquivo contendo o trecho que necessito extrair: 

    "MWTTanDeltaMean=27.0355 
    MWTTanDeltaSTD=2.3498 
    MWTTanDeltaChangeOverTime=1.8083
    MWTTanDeltaDuration= 15 
    MWTTanDeltaMeanPeakVoltage=34475.3700 
    MWTTanFrequency=0.1000
    MWTTanDeltaValues=
    27.5766;27.5707;27.3737;26.6112;26.0126;26.2416;26.1120;
    26.1621;25.7420;25.9710;25.6238;25.7683;25.8689;26.1269;
    26.1321;26.2643;25.7848;25.1501;25.3091;25.0000;25.3175;
    25.5920;24.8733;24.6167;24.6299;24.7430;25.4183;25.9896;
    25.4958;25.4259;26.4650;25.7657;30.0259;30.5261;30.2207;
    30.7683;30.5524;31.4316;30.5092;31.2188;31.3513;31.4804;
    31.1870;31.5287;31.2671;30.7482;29.5514;28.6546;29.6851;
    29.2009;29.2151;29.1309;29.1466;33.0232;31.8877;30.4890;
    26.8053;27.0559;26.8480;25.6997;25.8613;26.7863;26.0611;
    26.7878;27.2462;25.6071;25.9075;25.9302;25.8017;26.8502;
    26.7850;26.3517;25.5865;26.1033;25.8408;26.2310;25.0309;
    23.9557;24.0468;24.0217;23.7751;24.5628;24.3670;24.3429;
    25.5378;27.6765;24.4876;24.7278;23.9403;
    MWTTanDeltaTimeValues=
    25.8168;27.8008;27.0355;
    MWTTanDeltaSTDTimeValues= 
    0.7685;2.4520;2.3498; 
    MWTTanDeltaChangeTimeValues=
    ----------------------- 
    [Result]
    SmileyPhase1=3
    Temperature=
    MeasurementResult=0 
    TEST SEQUENCE COMPLETED SUCCESSFULLY
    2017-12-27 14.08"

     

    Essa solução iria resolver qualquer outro problema que eu pudesse ter no futuro. 

    Agradeço desde já!

     

    Abraço!!

    segunda-feira, 19 de fevereiro de 2018 19:35

Todas as Respostas

  • Eu creio que voce nao tera como fugir de uma leitura linha à linha, como motrado neste artigo: http://codevba.com/office/read_text_file_line_by_line.htm#.Wos24oPOWUk

    o codigo ficara mais ou menos assim:

    Dim strFilename As String: strFilename = "C:\temp\yourfile.txt"
    Dim strTextLine As String
    Dim iFile As Integer: iFile = FreeFile
    dim fim as boolean
    fim=false
    Open strFilename For Input As #iFile
    Do Until EOF(1) or fim  'leia até o fim do arquivo ou até a varial fim ser vedadeira
        Line Input #1, strTextLine
        if strTextLine="--------" then ' caso o texo lido seja ----- entao considere como fim
            fim=true
        end if
        ' tratar strTextLine e inserir as informaçoes no local correto
    
    Loop
    Close #iFile
    

    ou seja voce linha a linha até o fim do arquivo ou até encontrar uma string que voce considere como fim, que no seu caso eu acho que é a -----------------

    att


    William John Adam Trindade
    Analyste-programmeur


    Sogi Informatique ltée
    If you found this post helpful, please "Vote as Helpful". If it actually answered your question, remember to "Mark as Answer". Se achou este post útil, por favor clique em "Votar como útil". Se por acaso respondeu sua dúvida, lembre de "Marcar como Resposta".

    segunda-feira, 19 de fevereiro de 2018 20:50
  • William, 

    Agradeço a ajuda. O restante do arquivo eu já consigo extrair, utilizei como base esse site que você referenciou inclusive. O problema é que não sei como faço para o programa ler o arquivo até a linha "tal.1" e abaixo dela copiar os dados até chegar a linha "tal.2". 

    Se o código pegar apenas tudo que está abaixo da linha "MWTTanDeltaValues=" já me adianta, pois abaixo dessa linha são os dados que preciso e mais algumas linhas até o fim do arquivo.

    Agradeço a ajuda e abraço!


    • Editado MPlantier terça-feira, 20 de fevereiro de 2018 15:07
    terça-feira, 20 de fevereiro de 2018 15:06
  • Voce pode postar aqui um arquivo completo? FIca mais facil te ajudar com um exemplo real e completo.

    Diga, também,  quais informaçoes voce quer.

    Att


    William John Adam Trindade
    Analyste-programmeur


    Sogi Informatique ltée
    If you found this post helpful, please "Vote as Helpful". If it actually answered your question, remember to "Mark as Answer". Se achou este post útil, por favor clique em "Votar como útil". Se por acaso respondeu sua dúvida, lembre de "Marcar como Resposta".

    terça-feira, 20 de fevereiro de 2018 15:50
  • Bom se o seu arquivo txt, seguir este padrão apresentado no seu primeiro post, acredito que o código abaixo pode lha ajudar.

      

    Altere o nome do seu arquivo txt, na linha: 

    strPath = ThisWorkbook.Path & "\seutxt.txt"

        Dim fso As Object
        Dim f As Object
        Dim ts As Object
        Dim lr!
        Dim lc!
        Dim x!
        Dim j!
        Dim linText
        Dim txt As String
        Dim strPath As String
      
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        strPath = ThisWorkbook.Path & "\seutxt.txt"
        
        txt = fso.OpenTextFile(strPath).ReadAll
         
        Set f = fso.GetFile(strPath)
        
        Set ts = f.OpenAsTextStream(1, -2)
        
        With Plan1
            .Cells.Clear
            .Cells.Font.Name = "Arial Narrow"
            .Cells.Font.Size = 10
            
            Do While ts.AtEndOfStream = False
                
                linText = ts.ReadLine
                
                If VBA.Trim(VBA.Mid(linText, 1, 8)) Like "**.****;" Then
                    
                    lr = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                     j = 8
                     
                    For x = 0 To VBA.Len(linText) - VBA.Len(VBA.Replace(linText, ";", ""))
                    
                        If x = 0 Then
                            .Cells(lr, x + 1).Value = VBA.Left(linText, 7)
                        Else
                            .Cells(lr, x + 1).Value = VBA.Mid(linText, VBA.InStr(j, linText, ";") + 1, 7)
                            j = j + 7
                        End If
                    Next x
                    
                End If
                
                DoEvents
            Loop
            
            lc = .Cells(2, Columns.Count).End(xlToLeft).Column
            .Range(.Cells(1, "A"), .Cells(1, lc)).Interior.Color = vbYellow
            
        End With
        
        Set ts = Nothing
        Set f = Nothing







    terça-feira, 20 de fevereiro de 2018 17:00
  • Segue o link do arquivo no meu Drive: 

    <https://drive.google.com/open?id=1gb3BzlG8HC7vOlWdTaDtYEVIDwccdX4F>.

    A informação restante que quero é somente aquela que mencionei antes, que estão entre a linha "MWTTanDeltaValues=" e "MWTTanDeltaTimeValues=".  

    E abaixo está o meu código atual para o arquivo:

    Private Sub btR_Click()
    Dim fd              As Office.FileDialog 'variavel para ser a aplicação
    Dim ConteudoLinha   As String
    Dim txtFileName     As Variant
    Dim t               As Integer
    Dim w               As Worksheet 'Para controlar a Planilha DATA
    Dim wr              As Worksheet 'Para controlar a Planilha Fase R
    Dim r               As Integer
    Dim c               As Integer
    Dim l               As Integer
    Dim s               As Integer
    Dim f               As Integer
    
    Dim wksOutput       As Worksheet
    
    
    limpar
    
        Set w = Sheets("DATA")
        Set wr = Sheets("FaseR")
        
      
            Set fd = Application.FileDialog(msoFileDialogFilePicker)
            With fd
                .AllowMultiSelect = False             ' selecao varios arquivos
                .Title = "Please choose the file"
                  .Filters.Clear
                  .Filters.Add "Text Files", "*.txt"
                  .Filters.Add "BMF Files", "*.bmf"
                  .Filters.Add "BIF Files", "*.bif"
                  .Filters.Add "MMF Files", "*.mmf"
                  If .Show = True Then
                    txtFileName = .SelectedItems(1) 'transforma em txt
                    
                    ElseIf fd.Show = False Then
                    
                    MsgBox "Arquivo não selecionado, processo abortado"
                        
                        Exit Sub
                    
                  End If
               End With
            
                   
            Open fd.SelectedItems(1) For Input As #1
               
      
        r = 0 ' controle para factor
        c = 0 ' controle coluna database
        l = 0 ' controle linha  database
        s = 0 ' controle linha summary
        t = 0 ' Control
        f = 1 ' correcao para Frequency
        
    
        Do While Not EOF(1)      'Loop Until End of File (EOF)
        
            Line Input #1, ConteudoLinha
            
             If Left(ConteudoLinha, 8) = "[Header]" Then
                w.Cells(2 + t, 1) = "[Header]"
                w.Cells(2 + t, 1).Font.Bold = True 'Faz a celula ficar em negrito
                t = t + 1
             End If
    
            
            If Left(ConteudoLinha, 8) = "Version=" Then
            w.Cells(2 + t, 1) = "Version"
            w.Cells(2 + t, 2) = Mid(ConteudoLinha, 9)
            t = t + 1
            End If
            
            
            
            If Left(ConteudoLinha, 5) = "Name=" Then
            w.Cells(2 + t, 1) = "Name"
            w.Cells(2 + t, 2) = Mid(ConteudoLinha, 6)
            t = t + 1
            End If
        
            If Left(ConteudoLinha, 8) = "Content=" Then
                w.Cells(2 + t, 1) = "Content"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 9)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 11) = "ExportDate=" Then
                w.Cells(2 + t, 1) = "ExportDate"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 12)
                w.Cells(2 + t, 2).Replace What:=".", Replacement:="/"
                w.Cells(2 + t, 2).NumberFormat = "dd/mm/yyyy"
                t = t + 1
            End If
                
            If Left(ConteudoLinha, 11) = "ExportTime=" Then
                w.Cells(2 + t, 1) = "ExportTime"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 12)
                w.Cells(2 + t, 2).NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
                t = t + 1
            End If
           
            If Left(ConteudoLinha, 10) = "StartTime=" Then
                w.Cells(2 + t, 1) = "StartTime"
                w.Cells(2 + t, 1).Font.Bold = False
                w.Cells(2 + t, 2) = Right(ConteudoLinha, 8)
                w.Cells(2 + t, 2).NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
                t = t + 1
            End If
             
            If Left(ConteudoLinha, 12) = "[Cable Data]" Then
                w.Cells(2 + t, 1) = "[Cable Data]"
                w.Cells(2 + t, 1).Font.Bold = True
                t = t + 1
            End If
                
            If Left(ConteudoLinha, 13) = "LocationName=" Then
                w.Cells(2 + t, 1) = "LocationName"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 14)
                t = t + 1
            End If
                
            If Left(ConteudoLinha, 8) = "Utility=" Then
                w.Cells(2 + t, 1) = "Utility"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 9)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 10) = "FromPoint=" Then
                w.Cells(2 + t, 1) = "FromPoint"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 11)
                t = t + 1
            End If
                
            If Left(ConteudoLinha, 8) = "ToPoint=" Then
                w.Cells(2 + t, 1) = "ToPoint"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 9)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 15) = "NominalVoltage=" Then
                w.Cells(2 + t, 1) = "NominalVoltage"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 16)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 11) = "PhaseCount=" Then
                w.Cells(2 + t, 1) = "PhaseCount"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 12)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 15) = "[Program Data]" Then
                w.Cells(2 + t, 1) = "[Program Data]"
                w.Cells(2 + t, 1).Font.Bold = True
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 15)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 3) = "U0=" Then
                w.Cells(2 + t, 1) = "Uo"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 4)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 6) = "Phase=" Then
                w.Cells(2 + t, 1) = "Phase"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 7)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 7) = "Phases=" Then
                w.Cells(2 + t, 1) = "Phases"
                w.Cells(2 + t, 1).Font.Bold = False
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 8)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 6) = "Steps=" Then
                w.Cells(2 + t, 1) = "Steps"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 7)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 9) = "Measures=" Then
                w.Cells(2 + t, 1) = "Measures"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 10)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 7) = "Factor0" Then
                w.Cells(2 + t, 1) = "Factor0"
                w.Cells(2 + t, 2) = Right(ConteudoLinha, 6)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 7) = "Factor1" Then
                w.Cells(2 + t, 1) = "Factor1"
                w.Cells(2 + t, 2) = Right(ConteudoLinha, 6)
                t = t + 1
            End If
            
            If Left(ConteudoLinha, 7) = "Factor2" Then
                w.Cells(2 + t, 1) = "Factor2"
                w.Cells(2 + t, 2) = Right(ConteudoLinha, 6)
                t = t + 1
            End If
            
        
            If Left(ConteudoLinha, 10) = "Frequency=" And f = 1 Then
                w.Cells(2 + t, 1) = "Frequency"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 11, 5)
                t = t + 1
                f = f + 1
            End If
            
            If Left(ConteudoLinha, 17) = "[Evaluation Data]" Then
                w.Cells(2 + t, 1) = "[Evaluation Data]"
                w.Cells(2 + t, 1).Font.Bold = True
                t = t + 1
            End If
               
            If Left(ConteudoLinha, 18) = "ThresholdCritical=" Then
                w.Cells(2 + t, 1) = "ThresholdCritical"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 19)
                t = t + 1
            End If
            
             If Left(ConteudoLinha, 13) = "ThresholdBad=" Then
                w.Cells(2 + t, 1) = "ThresholdBad"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 14)
                t = t + 1
            End If
            
             If Left(ConteudoLinha, 15) = "ThresholdAbort=" Then
                w.Cells(2 + t, 1) = "ThresholdAbort"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 16)
                t = t + 1
            End If
            
             If Left(ConteudoLinha, 23) = "DeltaThresholdCritical=" Then
                w.Cells(2 + t, 1) = "DeltaThresholdCritical"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 24)
                t = t + 1
            End If
            
              If Left(ConteudoLinha, 18) = "DeltaThresholdBad=" Then
                w.Cells(2 + t, 1) = "DeltaThresholdBad"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 19)
                t = t + 1
            End If
            
              If Left(ConteudoLinha, 20) = "DeltaThresholdAbort=" Then
                w.Cells(2 + t, 1) = "DeltaThresholdAbort"
                w.Cells(2 + t, 2) = Mid(ConteudoLinha, 21)
                t = t + 1
            End If
            
    '---------------------------------------------------------------------------------------------------------------------------------------------
    
        If Left(ConteudoLinha, 9) = "TanDelta=" Then
            wr.Cells(11 + l, 3 + c) = Mid(ConteudoLinha, 10)
            wr.Cells(10, 3 + c) = "Medida TD " & c
        End If
    
    
        If Left(ConteudoLinha, 9) = "ShuntNbr=" Then
            wr.Cells(17 + l, 3 + c) = Mid(ConteudoLinha, 10)
            wr.Cells(16, 3 + c) = "ShuntNBR" & c
        End If
    
        If Left(ConteudoLinha, 9) = "Capacity=" Then
            wr.Cells(23 + l, 3 + c) = Mid(ConteudoLinha, 10)
            wr.Cells(22, 3 + c) = "Capacity" & c
        End If
    
        If Left(ConteudoLinha, 9) = "DIPkCurr=" Then
            wr.Cells(29 + l, 3 + c) = Mid(ConteudoLinha, 10)
            wr.Cells(28, 3 + c) = "DIPkCurr" & c
        End If
    
        If Left(ConteudoLinha, 9) = "DIPkVolt=" Then
            wr.Cells(35 + l, 3 + c) = Mid(ConteudoLinha, 10)
            wr.Cells(34, 3 + c) = "DIPkVolt" & c
        End If
        
        If Left(ConteudoLinha, 11) = "Resistance=" Then
            wr.Cells(41 + l, 3 + c) = Mid(ConteudoLinha, 12)
            wr.Cells(40, 3 + c) = "Resistance" & c
        End If
    
        If Left(ConteudoLinha, 13) = "Period-Dauer=" Then
            wr.Cells(47 + l, 3 + c) = Mid(ConteudoLinha, 14)
            wr.Cells(46, 3 + c) = "Period-Dauer" & c
        End If
    
        If Left(ConteudoLinha, 15) = "LeakCurrentPHG=" Then
            wr.Cells(53 + 1, 3 + c) = Mid(ConteudoLinha, 16)
            wr.Cells(52, 3 + c) = "LeakCurrentPHG" & c
        End If
    
        If Left(ConteudoLinha, 15) = "LeakCurrentVSE=" Then
            wr.Cells(59 + l, 3 + c) = Mid(ConteudoLinha, 16)
            wr.Cells(58, 3 + c) = "LeakCurrentVSE" & c
            c = c + 1
        End If
    
        If Left(ConteudoLinha, 13) = "MeanCapacity=" Then ' controle para fim de database / inicio do summary
            wr.Cells(4 + s, 3) = Mid(ConteudoLinha, 14)
            wr.Cells(3, 3) = "MeanCapacity"
            c = 0
            l = l + 1
         End If
    
        If Left(ConteudoLinha, 12) = "TanDeltaSTD=" Then
            wr.Cells(4 + s, 4) = Mid(ConteudoLinha, 13)
            wr.Cells(3, 4) = "TanDeltaSTD"
         End If
    
        If Left(ConteudoLinha, 13) = "MeanPeakVolt=" Then
            wr.Cells(4 + s, 5) = Mid(ConteudoLinha, 14)
            wr.Cells(3, 5) = "MeanPeakVolt"
         End If
    
        If Left(ConteudoLinha, 13) = "TanDeltaMean=" Then
            wr.Cells(4 + s, 6) = Mid(ConteudoLinha, 14)
            wr.Cells(3, 6) = "TanDeltaMean"
         End If
    
        If Left(ConteudoLinha, 14) = "DeltaTanDelta=" Then
            wr.Cells(4 + s, 7) = Mid(ConteudoLinha, 15)
            wr.Cells(3, 7) = "DeltaTanDelta"
         End If
    
        If Left(ConteudoLinha, 15) = "MeanResistance=" Then
            wr.Cells(4 + s, 8) = Mid(ConteudoLinha, 16)
            wr.Cells(3, 8) = "MeanResistance"
            s = s + 1
         End If
            
        
            
    
            Loop
    
    '------------------------------------------------------------------------------------------------------------------------------------------
    
    
    
            wr.Range("B3, B10, B16, B22, B28, B34, B40, B46, B52, B58") = "Voltage (p.u)"
            w.Select
            w.Range("B23:B25").Select
            Selection.Copy
            wr.Select
            wr.Range("B4,B11,B17,B23,B29,B35,B41,B47,B53,B59").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            
                    
            w.Range("B2:B50").HorizontalAlignment = xlRight 'alinha as celulas a direita
            w.Columns("A:Z").EntireColumn.AutoFit 'organiza automaticamente o tamanho das colunas
            wr.Columns("A:Z").EntireColumn.AutoFit
            
    
            frmMenu.lb1.Caption = "Importação Concluída. Clique em Sair ou escolha um novo arquivo." 'mensagem na caixa de menu
            
            w.Select
            w.Range("A1").Select
                    
          
            
    Close #1
    
    
    
    End Sub

     


    • Editado MPlantier terça-feira, 20 de fevereiro de 2018 17:26
    terça-feira, 20 de fevereiro de 2018 17:23
  • Bom se o seu arquivo txt, seguir este padrão apresentado no seu primeiro post, acredito que o código abaixo pode lha ajudar.

      
        Dim fso As Object
        Dim f As Object
        Dim ts As Object
        Dim lr!
        Dim lc!
        Dim x!
        Dim j!
        Dim linText
        Dim txt As String
        Dim strPath As String
      
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        strPath = ThisWorkbook.Path & "\seutxt.txt"
        
        txt = fso.OpenTextFile(strPath).ReadAll
         
        Set f = fso.GetFile(strPath)
        
        Set ts = f.OpenAsTextStream(1, -2)
        
        With Plan1
            .Cells.Clear
            .Cells.Font.Name = "Arial Narrow"
            .Cells.Font.Size = 10
            
            Do While ts.AtEndOfStream = False
                
                linText = ts.ReadLine
                
                If VBA.Trim(VBA.Mid(linText, 1, 8)) Like "**.****;" Then
                    
                    lr = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                     j = 8
                     
                    For x = 0 To VBA.Len(linText) - VBA.Len(VBA.Replace(linText, ";", ""))
                    
                        If x = 0 Then
                            .Cells(lr, x + 1).Value = VBA.Left(linText, 7)
                        Else
                            .Cells(lr, x + 1).Value = VBA.Mid(linText, VBA.InStr(j, linText, ";") + 1, 7)
                            j = j + 7
                        End If
                    Next x
                    
                End If
                
                DoEvents
            Loop
            
            lc = .Cells(2, Columns.Count).End(xlToLeft).Column
            .Range(.Cells(1, "A"), .Cells(1, lc)).Interior.Color = vbYellow
            
        End With
        
        Set ts = Nothing
        Set f = Nothing





    Vou testar e volto a responder. 

    Agradeço a ajuda!

    terça-feira, 20 de fevereiro de 2018 17:24
  • Bom se o seu arquivo txt, seguir este padrão apresentado no seu primeiro post, acredito que o código abaixo pode lha ajudar.

      

    Altere o nome do seu arquivo txt, na linha: 

    strPath = ThisWorkbook.Path & "\seutxt.txt"

        Dim fso As Object
        Dim f As Object
        Dim ts As Object
        Dim lr!
        Dim lc!
        Dim x!
        Dim j!
        Dim linText
        Dim txt As String
        Dim strPath As String
      
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        strPath = ThisWorkbook.Path & "\seutxt.txt"
        
        txt = fso.OpenTextFile(strPath).ReadAll
         
        Set f = fso.GetFile(strPath)
        
        Set ts = f.OpenAsTextStream(1, -2)
        
        With Plan1
            .Cells.Clear
            .Cells.Font.Name = "Arial Narrow"
            .Cells.Font.Size = 10
            
            Do While ts.AtEndOfStream = False
                
                linText = ts.ReadLine
                
                If VBA.Trim(VBA.Mid(linText, 1, 8)) Like "**.****;" Then
                    
                    lr = .Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                     j = 8
                     
                    For x = 0 To VBA.Len(linText) - VBA.Len(VBA.Replace(linText, ";", ""))
                    
                        If x = 0 Then
                            .Cells(lr, x + 1).Value = VBA.Left(linText, 7)
                        Else
                            .Cells(lr, x + 1).Value = VBA.Mid(linText, VBA.InStr(j, linText, ";") + 1, 7)
                            j = j + 7
                        End If
                    Next x
                    
                End If
                
                DoEvents
            Loop
            
            lc = .Cells(2, Columns.Count).End(xlToLeft).Column
            .Range(.Cells(1, "A"), .Cells(1, lc)).Interior.Color = vbYellow
            
        End With
        
        Set ts = Nothing
        Set f = Nothing







    Ricardo, agradeço imensamente sua ajuda!

    Fez exatamente o que eu necessitava, comecei a pouco a programar em VBA e conheço pouco ainda as instruções!

    Mais uma vez obrigado!!!!

    terça-feira, 20 de fevereiro de 2018 18:03