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

Question

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!!

Answer 1

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".

Answer 2

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!

Answer 3

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".

Answer 4

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

Answer 5

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

 

Answer 6

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!

Answer 7

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!!!!