Extract string from multiple files using vba

[matto666]

I need to extract a data from a set of text files inside a folder. I tried several times without success, I hope that someone can help me.

All the files I have to read are inside the folder C:/test. The data I need to extract from text file is located after a key word.

The data should be placed in an excel file (every data copied from a single text file inside a different cell).

Is there someone that can help me? I tried (with success) to write the macro for one single file, but I don't know how I can do it for all the files in my folder!!

[mancubus]

try:



Sub run_macro_on_all_files()

Dim strPath As String
Dim strFiles As String

strPath = "C:\test\"
If Not Dir(strPath & "*.txt") = "" Then 'test for existence of txt files
strFiles = Dir(strPath & "*.txt")
Do Until strFiles = ""
'paste your code here
'...
'...
'...
strFiles = Dir
Loop
End If

End Sub

[matto666]

Hi, and thanks for your help

you can see my code below. I don't receive any errors, but my excel file is blank..

Sub run_macro_on_all_files()

Dim strPath As String
Dim strFiles As String
Dim cella

strPath = "C:\prova\"
If Not Dir(strPath & "*.txt") = "" Then 'test for existence of txt files
strFiles = Dir(strPath & "*.txt")
Do Until strFiles = ""

Open strFiles For Input As #1

Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
'Close file
Close #1
ReadBRTLuminance = InStr(text, "Read BRT Luminance")
ActiveCell.Offset(cella, 1).Value = Mid(text, ReadBRTLuminance + 31, 9)
cella = cella + 1


strFiles = Dir
Loop
End If

End Sub

[mancubus]

you are welcome.

please use code tags when posting your code to the thread. When you click # button in Quick Reply code tags (without spaces) will be inserted.

[ CODE ]paste your code between these tags[ /CODE ]

you can find a number of examples about reading a txt file content here at VBAX.

below worked for me:



Sub ReadTextFile_FindString_WriteToCell()

Dim strPath As String, strFiles As String, strTxtFile As String Dim strToFind As String, strToWrite As String
Dim cella As Long

strPath = "C:\prova\"
strToFind = "Read BRT Luminance"
cella = 0

If Dir(strPath & "*.txt") = "" Then 'test for existence of txt files
MsgBox "No txt files in the directory: " & strPath
Exit Sub
End If

strFiles = Dir(strPath & "*.txt")
Do Until strFiles = ""
strTxtFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath & strFiles).ReadAll
strToWrite = Mid(strTxtFile, InStr(strTxtFile, strToFind) + 31, 9)
ActiveCell.Offset(cella, 1).Value = strToWrite
cella = cella + 1
strFiles = Dir
Loop


End Sub

[matto666]

IT WORKS!!!!!!!!!!!!!!!!!!!

Thanks, you're great!

[mancubus]

you are welcome.

mark the thread from Thread Tools dropdown which is above the first message for future references..