Compiling data from multiple excel files in multiple subfolders into one worksheet

D

DanSMT

Board Regular
Joined
Sep 13, 2019
Messages
203
Office Version
  1. 2013
Platform
  1. Windows
I hope im on the right track. Im trying to compile data from multiple files in multiple sub folders within a directory. The code appears the hang up when trying to imbed the information into the "pull from ri" sheet. Not sure what im missing here.

VBA Code: 
Sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "H:\ri\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    Dim WSL As String
    Dim LR As Long
    For Each File In Folder.Files
        ' Operate on each file
    Dim emptyRow As Long
    emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
        If InStr(File, ".xlsx") Then
        Workbooks("pull from ri").Worksheets("Sheet1").Activate
        Workbooks("pull from ri").Worksheets("sheet1").Cells(emptyRow, 1).text = File.Cells("c2").text
        End If
    Next
End Sub
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
The intent is to pull data into the row from multiple sources on this sheet and tie it to the part number. Once I figure this part out Ill be able to explain better if I have future questions. Thanks in advance.
 
Upvote 0
​
As per Logic the emptyRow = codeline should be after the workbook Activate codeline …​
To avoid this kind of logic error the better is to use a With block statement …​
​
Another point : you forgot to open the data source workbook !​
 
Last edited:
Upvote 0
Marc L said:
​
As per Logic the emptyRow = codeline should be after the workbook Activate codeline …​
To avoid this kind of logic error the better is to use a With block statement …​
​
Another point : you forgot to open the data source workbook !​
Click to expand...
How do I open the file if the filename is not given. File.open comes back as an error. Sorry new to this.
 
Upvote 0
​
Obviously to open an Excel workbook you must use the Excel Workbooks.Open statement​
as File object has nothin' to do with Excel but with FileSystemObject …​
 
Upvote 0
Thanks. Sorry new to this.

But I think I may be getting somewhere. However it is still not pulling the data I want as I am having an issue controlling the file once it is opened. See below;

VBA Code: 
Sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "H:\ri\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file
    With File
        If InStr(File, ".xlsx") Then
        Workbooks.Open (File)
            If InStr(File, "#0257") Then
                With ThisWorkbook.Sheets("Inspection Log Form")
                    .Range(Cells, "c2").Copy Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(2)
                End With
            Workbook.Close (File)
            ElseIf InStr(File, "#0258") Then
                With ThisWorkbook.Sheets("Report Checklist")
                    .Range(Cells, "c5").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(2)
                End With
            Workbook.Close (File)
            End If
        End If
    End With
    Next
End Sub
 
Upvote 0
I've changed the following

VBA Code: 
With ThisWorkbook.Sheets("Report Checklist")

to this

VBA Code: 
With Workbooks(File).ActiveSheet

The code now runs up to this point, however I get a mismatch at this point and I'm not understanding why.
 
Upvote 0
I've made some progress. But now im trying to add an if statement to it to check if the part number matches the list im generating to line up the data.

VBA Code: 
Sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "H:\ri\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file
    With File
        If InStr(File, ".xlsx") Then
        Workbooks.Open (File)
            If InStr(File, "#0257") Then
                With Workbooks(File).Worksheets("Inspection Log Form")
                    .Range(Cells, "c2").Copy Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(2)
                End With
            ActiveWorkbooks.Close
            ElseIf InStr(File, "#0258") Then
                With Workbooks.Open(File).ActiveSheet
                    If .Range("c4").Count = Workbooks("pull from ri").Sheets("sheet1").Range("a" & Rows.Count).Count Then
                    .Range("c5").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1)
                    End If
                    
                    
                End With
            ActiveWorkbooks.Close
            End If
        End If
    End With
    Next
End Sub
 
Upvote 0
Got the code working, however the return brings back the data onto seperate lines. I must be missing something. :/

And I believe i should turn off screen updating. Takes excessively long time to run.

VBA Code: 
Sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "H:\ri\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file
    With File
        If InStr(File, ".xlsx") Then
        Workbooks.Open (File)
            If InStr(File, "#0257") Then
                With Workbooks.Open(File).ActiveSheet
                    .Range("C2").Copy Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C3").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I2").Copy Workbooks("pull from ri").Sheets("sheet1").Range("F" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I3").Copy Workbooks("pull from ri").Sheets("sheet1").Range("H" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I4").Copy Workbooks("pull from ri").Sheets("sheet1").Range("R" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C6").Copy Workbooks("pull from ri").Sheets("sheet1").Range("K" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C7").Copy Workbooks("pull from ri").Sheets("sheet1").Range("L" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C8").Copy Workbooks("pull from ri").Sheets("sheet1").Range("N" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C9").Copy Workbooks("pull from ri").Sheets("sheet1").Range("M" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I6").Copy Workbooks("pull from ri").Sheets("sheet1").Range("P" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I9").Copy Workbooks("pull from ri").Sheets("sheet1").Range("O" & Rows.Count).End(xlUp)(1 + 1)
                End With
            ActiveWorkbook.Close
            ElseIf InStr(File, "#0258") Then
                With Workbooks.Open(File).ActiveSheet
                    .Range("C4").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C5").Copy Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C8").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D12").Copy Workbooks("pull from ri").Sheets("sheet1").Range("J" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D12").Copy Workbooks("pull from ri").Sheets("sheet1").Range("Q" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D13").Copy Workbooks("pull from ri").Sheets("sheet1").Range("R" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D14").Copy Workbooks("pull from ri").Sheets("sheet1").Range("W" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D15").Copy Workbooks("pull from ri").Sheets("sheet1").Range("H" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D16").Copy Workbooks("pull from ri").Sheets("sheet1").Range("S" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D17").Copy Workbooks("pull from ri").Sheets("sheet1").Range("X" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("J12").Copy Workbooks("pull from ri").Sheets("sheet1").Range("T" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("J13").Copy Workbooks("pull from ri").Sheets("sheet1").Range("Y" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("J14").Copy Workbooks("pull from ri").Sheets("sheet1").Range("U" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("J15").Copy Workbooks("pull from ri").Sheets("sheet1").Range("Z" & Rows.Count).End(xlUp)(1 + 1)
                    '.Range("J16").Copy Workbooks("pull from ri").Sheets("sheet1").Range("" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C19").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EW" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C20").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EX" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I19").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EY" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I20").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EZ" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D23").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AA" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D24").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AB" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D25").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AE" & Rows.Count).End(xlUp)(1 + 1)
                    '.Range("D26").Copy Workbooks("pull from ri").Sheets("sheet1").Range("" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("D27").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AC" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I22").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AF" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I23").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AG" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I24").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AH" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("I25").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AD" & Rows.Count).End(xlUp)(1 + 1)
                    '.Range("I26").Copy Workbooks("pull from ri").Sheets("sheet1").Range("" & Rows.Count).End(xlUp)(1 + 1)
                    
                End With
            ActiveWorkbook.Close
            End If
        End If
    End With
    Next
End Sub
 
Upvote 0
​
First, if many files within many subfolders so using FSO is not such a great idea as it can be slower than VBA Dir function !​
It could be not the case here if you have only Excel files in those folders.​
​
Yes you are right : you must desactivate the screen updating before to loop and re-activate it once done …​
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

O
  • Question
Converting a code to a UDF.
Replies
1
Views
339
offthelip
O
B
  • Solved
VBA macro to copy files from one folder (and all it's subfolders, and their subfolders, and their subfolders with an exception....) to another folder?
Replies
4
Views
717
Bering
B
H
  • Question
Macro to move csv files within-subfolder to folder "Old Templates"
Replies
2
Views
391
howard
H
K
  • Locked
  • Question
VBA Code to move subfolders and all files from source folder to destination folder
Replies
1
Views
914
Peter_SSs
Peter_SSs
S
  • Question
Loop through sub-folders and create shortcuts of each file
Replies
1
Views
956
Micron
M

Forum statistics

Threads
1,215,243
Messages
6,123,837
Members
449,129
Latest member
krishnamadison

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top