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

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!!
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". -
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
-
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". -
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
- Editado Ricardo Vba terça-feira, 20 de fevereiro de 2018 17:11
- Sugerido como Resposta William John Adam Trindade terça-feira, 20 de fevereiro de 2018 18:10
-
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
-
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!
-
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!!!!