Pulling data from multiple text files (and folders)

[tripkebab]

Hi Guys,

First post so hello!

I have been googling and searching forums for a while and havent found a working solution to my problem.

After reading a few threads here I understand you get frustrated with posts just asking for help and not actually including enough detail to provide a sutable awnser so I will try to give as much detail as possible.

I have come across another thread here where there is code posted to read multiple text files in VBA and import specific data to an excel spreadsheet. I have managed to use this code to get the results I desire, however unfortunatly the files I need to extract are also in multiple folders (all under a specific subfolder however).

I'm using the following code..

Sub read_text() 
     
     'Set wb = Workbooks.Add
    workingflnm = ActiveWorkbook.Name 
    i = 5 'First row in Active Sheet
    Set fd = CreateObject("Scripting.Filesystemobject") 
    pthnm = "[URL="file://gbdb1012/spparchive/SPP/110822/PRINT"]\\gbdb1012\spparchive\SPP\110822\PRINT[/URL]" 'Please change to your desired folder
    Set fs = fd.GetFolder(pthnm) 
    For Each fl In fs.Files 
         
         
        If InStr(1, fl.Name, "eodlog.spp", vbTextCompare) > 0 Then 
             
            Set Txtobj = CreateObject("Scripting.filesystemobject") 
            Set Txtfl = Txtobj.getfile(fl) 
            Set Txtstrm = Txtfl.openastextstream(1, -2) 
            Do While Txtstrm.AtEndOfStream <> True 
                rdln = Txtstrm.readline 
                 
                 
                If InStr(1, rdln, "rfsruc", vbTextCompare) > 1 Then 
                    x1 = InStr(1, rdln, "^", vbTextCompare) 
                    x2 = InStr(1, rdln, "^GBVC110007^", vbTextCompare) 
                    Workbooks(workingflnm).Sheets("Log File Extract").Cells(i, 1) = fl.Name 
                     'Construction of Ohms String
                    strg = Mid(rdln, x1 + Len("^"), x2 + Len("") - (x1 + Len("^"))) 'The String picks the character Ohms in the Line as well
                    Workbooks(workingflnm).Sheets("Log File Extract").Cells(i, 2) = strg 
                    i = i + 1 
                End If 
            Loop 
        End If 
         
    Next 
     
End Sub

This code will pull the data I require from the specified text file in \\gbdb1012\spparchive\SPP\110822\PRINT\

The folder stucture is as follows.

Root Folder
\\gbdb1012\spparchive\SPP\

Every Day a new folder is created in a YYMMDD format
\\gbdb1012\spparchive\SPP\110822\

Within this daily folder is another folder called print, in here is the file i need to pull data from
\\gbdb1012\spparchive\SPP\110822\PRINT


I need to be able to scan for text files in all the sub folders, i.e.

\\gbdb1012\spparchive\SPP\110821\PRINT
\\gbdb1012\spparchive\SPP\110822\PRINT
\\gbdb1012\spparchive\SPP\110823\PRINT
\\gbdb1012\spparchive\SPP\110824\PRINT
\\gbdb1012\spparchive\SPP\110825\PRINT
\\gbdb1012\spparchive\SPP\110826\PRINT
\\gbdb1012\spparchive\SPP\110827\PRINT

Obviously this is dynamic and ever changing so I imagine I will need some kind of loop to go though all the folders in the root folder one by one till it reaches the end?

Any suggestions on how I can alter the code to acomplish this?

Many thanks,


Please note this has been cross posted at...
http://www.ozgrid.com/forum/showthread.php?t=157461&p=572826#post572826

 

[Comfy]

If so try this:

Sub read_text()
Dim file As String
file = "\\gbdb1012\spparchive\SPP\110713\"
Call ListFilesInFolder(file, True)
End Sub
Function ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.file
Dim Curr_Row As Long
    Curr_Row = Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row + 1
    workingflnm = ActiveWorkbook.Name
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    For Each FileItem In SourceFolder.Files
        If InStr(1, FileItem.Name, "eodlog.spp", vbTextCompare) > 0 Then
 
            Set Txtfl = FSO.getfile(FileItem)
            Set Txtstrm = Txtfl.openastextstream(1, -2)
            Do While Txtstrm.AtEndOfStream <> True
                rdln = Txtstrm.readline
 
 
                If InStr(1, rdln, "Updt_Xfrs_Conv has completed successfully", vbTextCompare) > 1 Then
                    x1 = InStr(1, rdln, "^", vbTextCompare)
                    x2 = InStr(1, rdln, "^GBVC11", vbTextCompare)
                    Workbooks(workingflnm).Sheets("test").Cells(Curr_Row, 1) = FileItem.Path
                     'Construction of Ohms String
 
                    strg = Mid(rdln, x1 + Len("^"), x2 + Len("") - (x1 + Len("^"))) 'The String picks the character Ohms in the Line as well
                    Workbooks(workingflnm).Sheets("test").Cells(Curr_Row, 2) = strg
                    Curr_Row = Curr_Row + 1 ' next row number
                End If
 
            Loop
        End If
 
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True, Curr_Row
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Function

Sorry I'm not able to test.

My hdd that had my win7 install and xl07 died so waiting for a replacement as I cba to install everything on this crappy xp install.

 

[tripkebab]

Hi, sorry if im short (on my phone now).

Ideally id like to have it starting from row 5 and need to maintain the ability to choosee what column it would go in.

However if that would be time consuming for you i could always outpout the data to another sheet and then bring it into the main sheet with proper fornatting via linked cells

 

[Comfy]

Ok will have a play tommoz when Im back in work.

Thinking I'll go back to hard coding the row 5 as a requirement of the Function and then use an If statement to determine whether the first blank cell is 5 or greater if not the output will start at 5 if so it will start in that cell.

 

[tripkebab]

Sorry didnt c ur last post will try tomorow when im backbin the office. Back to good ol windows xp ay... well its still good for gaming on old rigs :D. You should get an ssd btw, ull never look back!

 

[Comfy]

Would love an ssd but I'm skint, got a wedding to pay for

 

[Comfy]

Give this ago:

Sub read_text()
Dim file As String
file = "\\gbdb1012\spparchive\SPP\110713\"
Call ListFilesInFolder(file, True, 5)
End Sub
Function ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean, RowStart As Long)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.file
Dim Curr_Row As Long
    If Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row > RowStart Then
        Curr_Row = Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row
    Else
        Curr_Row = RowStart
    End If
    workingflnm = ActiveWorkbook.Name
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    For Each FileItem In SourceFolder.Files
        If InStr(1, FileItem.Name, "eodlog.spp", vbTextCompare) > 0 Then
 
            Set Txtfl = FSO.getfile(FileItem)
            Set Txtstrm = Txtfl.openastextstream(1, -2)
            Do While Txtstrm.AtEndOfStream <> True
                rdln = Txtstrm.readline
 
 
                If InStr(1, rdln, "Updt_Xfrs_Conv has completed successfully", vbTextCompare) > 1 Then
                    x1 = InStr(1, rdln, "^", vbTextCompare)
                    x2 = InStr(1, rdln, "^GBVC11", vbTextCompare)
                    Workbooks(workingflnm).Sheets("test").Cells(Curr_Row, 1) = FileItem.Path
                     'Construction of Ohms String
 
                    strg = Mid(rdln, x1 + Len("^"), x2 + Len("") - (x1 + Len("^"))) 'The String picks the character Ohms in the Line as well
                    Workbooks(workingflnm).Sheets("test").Cells(Curr_Row, 2) = strg
                    Curr_Row = Curr_Row + 1 ' next row number
                End If
 
            Loop
        End If
 
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True, Curr_Row
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Function

 

[tripkebab]

Ah congratulations on the wedding, well that case throw the pots and pans out the window and get one as a wedding present :P

ok

Thanks gave this a run and its still semi working but just overwriting the same line :/ With my finess VBA skills i've tried adding in various +1's here and there to no avail!

 

[tripkebab]

I think the problem is here...

    If Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row > RowStart Then
        Curr_Row = Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row

    Else
        Curr_Row = RowStart
    End If

If i change the code so its like this it starts at like row 8 but works properly and adds each entry to a new line.

[CODE] 
    If Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row > RowStart Then
        Curr_Row = Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row

    Else
        Curr_Row = RowStart +1
    End If

[/CODE]

So looks like the first query isnt returning the desired results?

 

[tripkebab]

Ok just changed the top sub to start at row 2...

Sub read_text()
Dim file As String
file = "\\gbdb1012\spparchive\SPP\110713\"
Call ListFilesInFolder(file, True, 2)

And now its starting at row 5 as intended but im not sure this is the ideal way to have this working?

 

[Comfy]

It was an oversight on my part, hopefully this will work.

Sub read_text()
Dim file As String
file = "\\gbdb1012\spparchive\SPP\110713\"
Call ListFilesInFolder(file, True, 5)
End Sub
Function ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean, RowStart As Long)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.file
Dim Curr_Row As Long
    If Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row > RowStart Then
        Curr_Row = Workbooks(workingflnm).Sheets("test").Range("A65536").End(xlUp).Row + 1 'This was the problem
    Else
        Curr_Row = RowStart
    End If
    workingflnm = ActiveWorkbook.Name
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    For Each FileItem In SourceFolder.Files
        If InStr(1, FileItem.Name, "eodlog.spp", vbTextCompare) > 0 Then
 
            Set Txtfl = FSO.getfile(FileItem)
            Set Txtstrm = Txtfl.openastextstream(1, -2)
            Do While Txtstrm.AtEndOfStream <> True
                rdln = Txtstrm.readline
 
 
                If InStr(1, rdln, "Updt_Xfrs_Conv has completed successfully", vbTextCompare) > 1 Then
                    x1 = InStr(1, rdln, "^", vbTextCompare)
                    x2 = InStr(1, rdln, "^GBVC11", vbTextCompare)
                    Workbooks(workingflnm).Sheets("test").Cells(Curr_Row, 1) = FileItem.Path
                     'Construction of Ohms String
 
                    strg = Mid(rdln, x1 + Len("^"), x2 + Len("") - (x1 + Len("^"))) 'The String picks the character Ohms in the Line as well
                    Workbooks(workingflnm).Sheets("test").Cells(Curr_Row, 2) = strg
                    Curr_Row = Curr_Row + 1 ' next row number
                End If
 
            Loop
        End If
 
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True, Curr_Row
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Function