Oi,
seguinte preciso que seja desenvolvida uma macro que busque em uma pasta arquivos textos que são colocados todos os dias e verifique nestes arquivos se existe um número específico e autalize uma planilha dizendo Ok onde tem este número e na frente quantas foram encontradas.
Os arquivos textos não tem cabeçalho.
Abs.
Padunic
padunic@ig.com.br
Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E
Desenvolver uma macro
Re: Desenvolver uma macro
Oi
Não consegui anexar o arquivo, ai vai.
Private Sub CommandButton1_Click()
Dim fs, f, f1, fc, vdir
vdir = "c:\teste\"
vdir = "C:\_Equipe\_Ricardo\comodato\2012\janeiro\lixo\"
vnr_procurar = "1234"
Sheets(1).Columns("A:A").Select
Selection.ClearContents
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(vdir)
Set fc = f.Files
linha = 1
Sheets(1).Cells(linha, 1) = "Arquivo"
Sheets(1).Cells(linha, 2) = "Nr Vezes"
For Each f1 In fc
If InStr(UCase(f1.Name), "TQS_SINAF_D") > 0 And InStr(UCase(f1.Name), ".TXT") > 0 Then
vNome_Arq_Completo = vdir + f1.Name
Set oSistemaArquivo = CreateObject("Scripting.FileSystemObject")
Set arquivo = oSistemaArquivo.OpenTextFile(vNome_Arq_Completo, 1, False, -2)
vQtde = 0
Do While arquivo.AtEndOfStream <> True
If InStr(arquivo.ReadLine, vnr_procurar) > 0 Then
vQtde = vQtde + 1
End If
Loop
oSistemaArquivo = Null
arquivo = Null
linha = linha + 1
Sheets(1).Cells(linha, 1) = f1.Name
Sheets(1).Cells(linha, 2) = vQtde
End If
Next
End Sub
Boa sorte
Eduardo
Não consegui anexar o arquivo, ai vai.
Private Sub CommandButton1_Click()
Dim fs, f, f1, fc, vdir
vdir = "c:\teste\"
vdir = "C:\_Equipe\_Ricardo\comodato\2012\janeiro\lixo\"
vnr_procurar = "1234"
Sheets(1).Columns("A:A").Select
Selection.ClearContents
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(vdir)
Set fc = f.Files
linha = 1
Sheets(1).Cells(linha, 1) = "Arquivo"
Sheets(1).Cells(linha, 2) = "Nr Vezes"
For Each f1 In fc
If InStr(UCase(f1.Name), "TQS_SINAF_D") > 0 And InStr(UCase(f1.Name), ".TXT") > 0 Then
vNome_Arq_Completo = vdir + f1.Name
Set oSistemaArquivo = CreateObject("Scripting.FileSystemObject")
Set arquivo = oSistemaArquivo.OpenTextFile(vNome_Arq_Completo, 1, False, -2)
vQtde = 0
Do While arquivo.AtEndOfStream <> True
If InStr(arquivo.ReadLine, vnr_procurar) > 0 Then
vQtde = vQtde + 1
End If
Loop
oSistemaArquivo = Null
arquivo = Null
linha = linha + 1
Sheets(1).Cells(linha, 1) = f1.Name
Sheets(1).Cells(linha, 2) = vQtde
End If
Next
End Sub
Boa sorte
Eduardo