VBA extract sheet data from multiple subfolders into master

[terriertrip]

Hello all. I've been searching for several days and trying different techniques with no apparent success, so I'm hoping someone can see what I have and have a better solution. The most comprehensive, succinct, and successful code I've been able to construct with the help of many, is the example below, however, the code doesn't look in subfolders and there are a couple of tweaks that I haven't been able to configure.

I've attached an example data set. The data sets are ASCII coded (basically you can see all data is read within column 1). All data are space delimited. The header information can remain intact, but once transferred it needs to autofill to lastrow of each relative data set. I've got some code that can delimit out data sets and remove the ASCII headers, so I think I can deal with delimiting it after all the files are transferred, but why isn't it looping through the sub-directories?

Sub Consolidate()

    Dim Fs As Object 'FileSystem
    Dim d As Object 'Folder
    Dim Fx As Object 'Subfolder
    Dim file As Object 'File
    Dim PathName As String
    Dim iRow As Long 'next available row index of destination worksheet
    Dim LastRow As Long 'last row of source worksheet
    Dim wbSource As Workbook, wsMaster As Worksheet
    
    Set wsMaster = ThisWorkbook.Sheets("Master") 'sheet data will be compiled into

    With wsMaster 'data destination worksheet
        Set Fs = CreateObject("Scripting.FileSystemObject")
        Set d = Fs.GetFolder("Z:\Operations\Chupacabra\Data\")
        iRow = 2
        
        For Each Fx In d.SubFolders 'loop through subfolders
            For Each file In Fx.Files 'loop through files
                If file.Name Like "*dq1000d.las*" Then
                    PathName = Fx.Name & "\" & file.Name
                    Workbooks.Open d.Path & "\" & PathName
                    Application.StatusBar = "Processing " & PathName
                    LastRow = Range("A" & Rows.Count).End(xlUp).Row + 1 'Find & copy to last row having data in column A
                    Range("A132:A" & LastRow).Copy .Range("A" & iRow)    'this original data is space delmited
                    Range("A13").Copy .Range("B" & iRow)                 'header data needs to remain intact & autofill
                    Range("A12").Copy .Range("C" & iRow)                 'header data needs to remain intact & autofill
                    Range("A23").Copy .Range("D" & iRow)                 'header data needs to remain intact & autofill
                    iRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1   'Next row
                    ActiveWorkbook.Close savechanges:=False
                End If
                iRow = iRow + LastRow
            Next file
        Next Fx
    End With
End Sub

[terriertrip]

a humble 'bump'

[Leith Ross]

Hello terriertrip,

The problem was not the subfolders. It was the data was overwriting itself.

This macro solves the problem and works much faster since no workbook is being opened to parse the data.

Sub Consolidate2()

    Dim ByteData()  As Byte
    Dim cnt         As Long
    Dim FISdata     As String
    Dim Fs          As Object 'FileSystem
    Dim d           As Object 'Folder
    Dim Fx          As Object 'Subfolder
    Dim file        As Object 'File
    Dim Headers     As Variant
    Dim n           As Long
    Dim iRow        As Long 'next available row index of destination worksheet
    Dim Text        As String
    Dim wsMaster    As Worksheet
    
        iRow = 2
        Set wsMaster = ThisWorkbook.Sheets("Master") 'sheet data will be compiled into
        
            n = wsMaster.Cells(Rows.Count, "A").End(xlUp).Row
            If n > iRow Then iRow = n + 1
            
            Set Fs = CreateObject("Scripting.FileSystemObject")
            
            Set d = Fs.GetFolder("Z:\Operations\Chupacabra\Data\")
            
            For Each Fx In d.Subfolders 'loop through subfolders
                For Each file In Fx.Files 'loop through files
                    If file.Name Like "*dq1000d.las*" Then
                        Open file.Path For Binary Access Read As #1
                            ReDim ByteData(LOF(1))
                            Get #1, , ByteData
                        Close #1
                        
                        Text = StrConv(ByteData, vbUnicode)
                        Lines = Split(Text, vbCrLf)
                        
                        cnt = 0
                        ReDim Headers(2)
                            For n = 0 To UBound(Lines) - 1
                                If Left(Lines(n), 6) = "COMP. " Then Headers(0) = Lines(n): cnt = cnt + 1
                                If Left(Lines(n), 6) = "WELL. " Then Headers(1) = Lines(n): cnt = cnt + 1
                                If Left(Lines(n), 5) = "API. " Then Headers(2) = Lines(n): cnt = cnt + 1
                                If cnt = 3 Then Exit For
                            Next n
                        
                        n = InStrRev(Text, "~Ascii FIS DATA") + 17
                        FISdata = Mid(Text, n, Len(Text) - n)
                        Lines = Split(FISdata, vbCrLf)
                        
                        wsMaster.Range("B" & iRow).Resize(1, 3).Value = Headers
                        iRow = iRow + 1
                        
                        Lines = Application.Transpose(Lines)
                        wsMaster.Range("A" & iRow).Resize(UBound(Lines), 1).Value = Lines
                        iRow = iRow + UBound(Lines) - 1
                    End If
                Next file
            Next Fx
        
End Sub

[terriertrip]

Thank you so much Leith for your reply. I'm sorry I haven't been able to test the code yet. I got pulled to another direction yesterday. I will give it a go before I leave work today. If it does work **fingers crossed**, I'll let you know. I'm not sure how long it would take once it executes, so I'll let it run overnight. There's probably several hundred files it has to pull with sets of 15k x 110 data. It's all going into an ADB after compilation. I'll keep you posted.

[terriertrip]

Hi Leith. Code doesn't error, but nothing happens. I tested it on several different paths that contained sample files and nothing happens. If I give a bogus path, it errors there but otherwise doa. The code is in a module and I'm running it from there. Any suggestions?

[Leith Ross]

Hello terriertrip,

One 2 reasons I can think of that would cause that behaviour. Either there are no subfolders in the folder "Z:\Operations\Chupacabra\Data\" or there are no files in the subfolders whose names match "*dq1000d.las*". I tested the macro by creating a couple of subfolders and adding in your file and modifying the copies to tell them apart. everything worked on my end. I did the test on my "C" drive and one of my network folders. It was all good.

[terriertrip]

Hmmm. There are definitely subfolders and there are 2-3 files within different files named dq1000d.las. Like I said, I tried on both my local drive and our network drive to test it before attempting the entire directory. I have other routines that call files up on the network drive, so it isn't an issue of security. Since it's working on your end, the only thing I can think of is, is there a reference that I may not have enabled within my vba tools menu? Is there some sort of error handling that I could implement to step through the code? Microsoft Scripting Runtime enabled. I'm running Excel 2016 on windows 10. Code looks good. Totally stumped.

[terriertrip]

One thing that occured to me, the file I attached was a text file - only because EF wouldn't allow the attachment of the file in it's native format. I changed the extention to (*.txt) to upload. The actual file is an industry specific Log ASCII Standard format. (*.las). Could there be a conflict? Although, I changed the files to (*.txt) along with the IfThen code, but still just a flicker and a blank ws. sigh...