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]

I use this to loop through a Folder and it's subfolders to return document properties but you could just change it to suit your needs.

Option Explicit
Function BrowseForFolder(Optional OpenAt As Variant) As String
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function
Sub Print_Dir_Contents()
   Dim Input_Dir As String
'   Dim Curr_Row, Curr_Col, Counter As Integer
   
   
    Input_Dir = BrowseForFolder
    Call ListFilesInFolder(Input_Dir, True)
   
End Sub
Sub 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, Curr_Col, Counter As Integer

    Curr_Row = Range("A65536").End(xlUp).row + 1
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(Curr_Row, 1).Formula = SourceFolder.Name
        Cells(Curr_Row, 2).Formula = FileItem.Name
        Cells(Curr_Row, 3).Formula = ReadPropertyFromClosedFile(FileItem.Path, "Comments", PropertyLocationBuiltIn)
        Cells(Curr_Row, 4).Formula = ReadPropertyFromClosedFile(FileItem.Path, "Author", PropertyLocationBuiltIn)
'        Cells(r, 5).Formula = FileItem.DateLastAccessed
'        Cells(Curr_Row, 2).Formula = FileItem.DateLastModified
'        Cells(r, 7).Formula = FileItem.Attributes
'        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
        ' use file methods (not proper in this example)
'        FileItem.Copy "C:\FolderName\Filename.txt", True
'        FileItem.Move "C:\FolderName\Filename.txt"
'        FileItem.Delete True
        Curr_Row = Curr_Row + 1 ' next row number
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

 

[tripkebab]

Hi thanks for the responce, sorry I should have mentioned i'm not the best with VB.

I have tried using your code but when I execute (after choosing folder) its erroring on..

Sub listfilesinfolder

Error message states, user defined type not defined.


While I may be able to toy with your code (once working) to suit my needs is there no easy way to update my code thats already configured to encorporate this functionality so it searches sub folders of a hard coded root folder?

Many thanks,

 

[Comfy]

Yep, will have a look for you.

 

[tripkebab]

Brilliant thanks very much, greatly appreciated.

 

[Comfy]

Ok, give this ago.

It might not be perfect but it's a start.

Sub read_text()
Dim file As String

file = "\\gbdb1012\spparchive\SPP\110822\PRINT"
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

    Curr_Row = RowStart
    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, "rfsruc", vbTextCompare) > 1 Then
                    x1 = InStr(1, rdln, "^", vbTextCompare)
                    x2 = InStr(1, rdln, "^GBVC110007^", vbTextCompare)
                    Workbooks(workingflnm).Sheets("Log File Extract").Cells(Curr_Row, 1) = FileItem.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(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

/Comfy

 

[tripkebab]

Thanks, gave this a go but still getting same error as original.

Iv never used functions before so I may be doing something wrong??

I'm running the read_text sub and it immidiatly errors saying.

Compile error:
User-defined type not defined.

Highlighting the following line of code.
Function Listfilesinfolder (sourcefoldername as string, includesubfolders as boolean, rowstart as long) in yellow.

And also selecting the following bit of code.. FSO as scripting.filesystemobject.

 

[Comfy]

Ahh. Forgot to mention about adding a Reference. Doh!..... it's been along day

In the VB window go to:

Tools > References

Tick Microsoft Scripting Runtime

 

[tripkebab]

Thanks again,

Making Progress now!

Wasnt working at first but this was because the workingflnm = activeworkbook.name was missing.

I'm still getting one issue however.

My code is now as follows.

Sub read_text()
Dim file As String
file = "[URL="file://gbdb1012/spparchive/SPP/110713/"]\\gbdb1012\spparchive\SPP\110713\[/URL]"
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
    Curr_Row = RowStart
    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

When I run the code on a directory with one file that has multiple entries it works fine and lists all the data I want, row after row.

However when I run on a higher folder so it picks up multiple files, it picks up the correct data and writes it to row 5, but then when it find the next file it overwrites whats in row 5 with the info from the next file.

I can see the Curr_Row = Curr_Row + 1 ' next row number thats in my bit of code but im guessing there needs to be something similar in this section?

Sub read_text()
Dim file As String
file = "[URL="file://gbdb1012/spparchive/SPP/110713/"]\\gbdb1012\spparchive\SPP\110713\[/URL]"
Call ListFilesInFolder(file, True, 5)
End Sub

Seems that the row 5 is hard coded there?

 

[Comfy]

Yes, I took that from your original code.

Would it be ok if the code started entering info in the first blank cell in column 1?